mirror of https://github.com/Chizi123/.emacs.d.git

Chizi123
2018-11-18 434b46beff1c5ec01cbefd5273d89971a82d6bab
commit | author | age
5cb5f7 1 ;;; helm-ring.el --- kill-ring, mark-ring, and register browsers for helm. -*- lexical-binding: t -*-
C 2
3 ;; Copyright (C) 2012 ~ 2018 Thierry Volpiatto <thierry.volpiatto@gmail.com>
4
5 ;; This program is free software; you can redistribute it and/or modify
6 ;; it under the terms of the GNU General Public License as published by
7 ;; the Free Software Foundation, either version 3 of the License, or
8 ;; (at your option) any later version.
9
10 ;; This program is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13 ;; GNU General Public License for more details.
14
15 ;; You should have received a copy of the GNU General Public License
16 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
17
18 ;;; Code:
19
20 (require 'cl-lib)
21 (require 'helm)
22 (require 'helm-utils)
23 (require 'helm-help)
24 (require 'helm-elisp)
25
26 (declare-function undo-tree-restore-state-from-register "ext:undo-tree.el" (register))
27
28
29 (defgroup helm-ring nil
30   "Ring related Applications and libraries for Helm."
31   :group 'helm)
32
33 (defcustom helm-kill-ring-threshold 3
34   "Minimum length of a candidate to be listed by `helm-source-kill-ring'."
35   :type 'integer
36   :group 'helm-ring)
37
38 (defcustom helm-kill-ring-max-offset 400
39   "Max number of chars displayed per candidate in kill-ring browser.
40 When `t', don't truncate candidate, show all.
41 By default it is approximatively the number of bits contained in five lines
42 of 80 chars each i.e 80*5.
43 Note that if you set this to nil multiline will be disabled, i.e you
44 will not have anymore separators between candidates."
45   :type '(choice (const :tag "Disabled" t)
46           (integer :tag "Max candidate offset"))
47   :group 'helm-ring)
48
49 (defcustom helm-kill-ring-actions
50   '(("Yank marked" . helm-kill-ring-action-yank)
51     ("Delete marked" . helm-kill-ring-action-delete))
52   "List of actions for kill ring source."
53   :group 'helm-ring
54   :type '(alist :key-type string :value-type function))
55
56 (defcustom helm-kill-ring-separator "\n"
57   "The separator used to separate marked candidates when yanking."
58   :group 'helm-ring
59   :type 'string)
60
61 (defcustom helm-register-max-offset 160
62   "Max size of string register entries before truncating."
63   :group 'helm-ring
64   :type  'integer)
65
66 ;;; Kill ring
67 ;;
68 ;;
69 (defvar helm-kill-ring-map
70   (let ((map (make-sparse-keymap)))
71     (set-keymap-parent map helm-map)
72     (define-key map (kbd "M-y")     'helm-next-line)
73     (define-key map (kbd "M-u")     'helm-previous-line)
74     (define-key map (kbd "M-D")     'helm-kill-ring-delete)
75     (define-key map (kbd "C-]")     'helm-kill-ring-toggle-truncated)
76     (define-key map (kbd "C-c C-k") 'helm-kill-ring-kill-selection)
77     map)
78   "Keymap for `helm-show-kill-ring'.")
79
80 (defvar helm-source-kill-ring
81   (helm-build-sync-source "Kill Ring"
82     :init (lambda ()
83             (helm-attrset 'last-command last-command)
84             (helm-attrset 'multiline helm-kill-ring-max-offset))
85     :candidates #'helm-kill-ring-candidates
86     :filtered-candidate-transformer #'helm-kill-ring-transformer
87     :action 'helm-kill-ring-actions
88     :persistent-action 'ignore
89     :help-message 'helm-kill-ring-help-message
90     :persistent-help "DoNothing"
91     :keymap helm-kill-ring-map
92     :migemo t
93     :multiline 'helm-kill-ring-max-offset
94     :group 'helm-ring)
95   "Source for browse and insert contents of kill-ring.")
96
97 (defun helm-kill-ring-candidates ()
98   (cl-loop for kill in (helm-fast-remove-dups kill-ring :test 'equal)
99         unless (or (< (length kill) helm-kill-ring-threshold)
100                    (string-match "\\`[\n[:blank:]]+\\'" kill))
101         collect kill))
102
103 (defun helm-kill-ring-transformer (candidates _source)
104   "Ensure CANDIDATES are not read-only."
105   (cl-loop for i in candidates
106            when (get-text-property 0 'read-only i)
107            do (set-text-properties 0 (length i) '(read-only nil) i)
108            collect i))
109
110 (defvar helm-kill-ring--truncated-flag nil)
111 (defun helm-kill-ring-toggle-truncated ()
112   "Toggle truncated view of candidates in helm kill-ring browser."
113   (interactive)
114   (with-helm-alive-p
115     (setq helm-kill-ring--truncated-flag (not helm-kill-ring--truncated-flag))
116     (let* ((cur-cand (helm-get-selection))
117            (presel-fn (lambda ()
118                         (helm-kill-ring--preselect-fn cur-cand))))
119       (helm-attrset 'multiline
120                     (if helm-kill-ring--truncated-flag
121                         15000000
122                         helm-kill-ring-max-offset))
123         (helm-update presel-fn))))
124 (put 'helm-kill-ring-toggle-truncated 'helm-only t)
125
126 (defun helm-kill-ring-kill-selection ()
127   "Store the real value of candidate in kill-ring.
128 Same as `helm-kill-selection-and-quit' called with a prefix arg."
129   (interactive)
130   (helm-kill-selection-and-quit t))
131 (put 'helm-kill-ring-kill-selection 'helm-only t)
132
133 (defun helm-kill-ring--preselect-fn (candidate)
134   "Internal, used to preselect CANDIDATE when toggling truncated view."
135   ;; Preselection by regexp may not work if candidate is huge, so walk
136   ;; the helm buffer until selection is on CANDIDATE.
137   (helm-awhile (condition-case-unless-debug nil
138                    (and (not (helm-pos-header-line-p))
139                         (helm-get-selection))
140                  (error nil))
141     (if (string= it candidate)
142         (cl-return)
143         (helm-next-line))))
144
145 (defun helm-kill-ring-action-yank (_str)
146   "Insert concatenated marked candidates in current-buffer.
147
148 When two prefix args are given prompt to choose separator, otherwise
149 use `helm-kill-ring-separator' as default."
150   (let ((marked (helm-marked-candidates))
151         (sep (if (equal helm-current-prefix-arg '(16))
152                  (read-string "Separator: ")
153                helm-kill-ring-separator)))
154     (helm-kill-ring-action-yank-1
155      (cl-loop for c in (butlast marked)
156               concat (concat c sep) into str
157               finally return (concat str (car (last marked)))))))
158
159 (defun helm-kill-ring-action-yank-1 (str)
160   "Insert STR in `kill-ring' and set STR to the head.
161
162 When called with a prefix arg, point and mark are exchanged without
163 activating region.
164 If this action is executed just after `yank',
165 replace with STR as yanked string."
166   (let ((yank-fn (lambda (&optional before yank-pop)
167                    (insert-for-yank str)
168                    ;; Set the window start back where it was in
169                    ;; the yank command, if possible.
170                    (when yank-pop
171                      (set-window-start (selected-window) yank-window-start t))
172                    (when (or (equal helm-current-prefix-arg '(4)) before)
173                      ;; Same as exchange-point-and-mark but without
174                      ;; activating region.
175                      (goto-char (prog1 (mark t)
176                                   (set-marker (mark-marker)
177                                               (point)
178                                               helm-current-buffer)))))))
179     ;; Prevent inserting and saving highlighted items.
180     (set-text-properties 0 (length str) nil str)
181     (with-helm-current-buffer
182       (unwind-protect
183            (progn
184              (setq kill-ring (delete str kill-ring))
185              ;; Adding a `delete-selection' property
186              ;; to `helm-kill-ring-action' is not working
187              ;; because `this-command' will be `helm-maybe-exit-minibuffer',
188              ;; so use this workaround (Issue #1520).
189              (when (and (region-active-p) delete-selection-mode)
190                (delete-region (region-beginning) (region-end)))
191              (if (not (eq (helm-attr 'last-command helm-source-kill-ring) 'yank))
192                  (progn
193                    ;; Ensure mark is at beginning of inserted text.
194                    (push-mark)
195                    ;; When yanking in a helm minibuffer we need a small
196                    ;; delay to detect the mark in previous minibuffer. [1]
197                    (run-with-timer 0.01 nil yank-fn))
198                ;; from `yank-pop'
199                (let ((inhibit-read-only t)
200                      (before (< (point) (mark t))))
201                  (if before
202                      (funcall (or yank-undo-function 'delete-region) (point) (mark t))
203                    (funcall (or yank-undo-function 'delete-region) (mark t) (point)))
204                  (setq yank-undo-function nil)
205                  (set-marker (mark-marker) (point) helm-current-buffer)
206                  ;; Same as [1] but use the same mark and point as in
207                  ;; the initial yank according to BEFORE even if no
208                  ;; prefix arg is given.
209                  (run-with-timer 0.01 nil yank-fn before 'pop))))
210         (kill-new str)))))
211 (define-obsolete-function-alias 'helm-kill-ring-action 'helm-kill-ring-action-yank "2.4.0")
212
213 (defun helm-kill-ring-action-delete (_candidate)
214   "Delete marked candidates from `kill-ring'."
215   (cl-loop for c in (helm-marked-candidates)
216            do (setq kill-ring
217                     (delete c kill-ring))))
218
219 (defun helm-kill-ring-delete ()
220   "Delete marked candidates from `kill-ring'.
221
222 This is a command for `helm-kill-ring-map'."
223   (interactive)
224   (with-helm-alive-p
225     (helm-exit-and-execute-action 'helm-kill-ring-action-delete)))
226
227
228 ;;;; <Mark ring>
229 ;; DO NOT use these sources with other sources use
230 ;; the commands `helm-mark-ring', `helm-global-mark-ring' or
231 ;; `helm-all-mark-rings' instead.
232
233 (defun helm-mark-ring-line-string-at-pos (pos)
234   "Return line string at position POS."
235   (save-excursion
236     (goto-char pos)
237     (forward-line 0)
238     (let ((line (car (split-string (thing-at-point 'line) "[\n\r]"))))
239       (remove-text-properties 0 (length line) '(read-only) line)
240       (if (string= "" line)
241           "<EMPTY LINE>"
242         line))))
243
244 (defun helm-mark-ring-get-candidates ()
245   (with-helm-current-buffer
246     (cl-loop with marks = (if (mark t)
247                               (cons (mark-marker) mark-ring)
248                             mark-ring)
249              for marker in marks
250              with max-line-number = (line-number-at-pos (point-max))
251              with width = (length (number-to-string max-line-number))
252              for m = (format (concat "%" (number-to-string width) "d: %s")
253                              (line-number-at-pos marker)
254                              (helm-mark-ring-line-string-at-pos marker))
255              unless (and recip (assoc m recip))
256              collect (cons m marker) into recip
257              finally return recip)))
258
259 (defun helm-mark-ring-default-action (candidate)
260   (let ((target (copy-marker candidate)))
261     (helm-aif (marker-buffer candidate)
262         (progn
263           (switch-to-buffer it)
264           (helm-log-run-hook 'helm-goto-line-before-hook)
265           (helm-match-line-cleanup)
266           (with-helm-current-buffer
267             (unless helm-yank-point (setq helm-yank-point (point))))
268           (helm-goto-char target)
269           (helm-highlight-current-line))
270       ;; marker points to no buffer, no need to dereference it, just
271       ;; delete it.
272       (setq mark-ring (delete target mark-ring))
273       (error "Marker points to no buffer"))))
274
275 (defvar helm-source-mark-ring
276   (helm-build-sync-source "mark-ring"
277     :candidates #'helm-mark-ring-get-candidates
278     :action '(("Goto line" . helm-mark-ring-default-action))
279     :persistent-help "Show this line"
280     :group 'helm-ring))
281
282 ;;; Global-mark-ring
283 (defvar helm-source-global-mark-ring
284   (helm-build-sync-source "global-mark-ring"
285     :candidates #'helm-global-mark-ring-get-candidates
286     :action '(("Goto line" . helm-mark-ring-default-action))
287     :persistent-help "Show this line"
288     :group 'helm-ring))
289
290 (defun helm-global-mark-ring-format-buffer (marker)
291   (with-current-buffer (marker-buffer marker)
292     (goto-char marker)
293     (forward-line 0)
294     (let ((line (pcase (thing-at-point 'line)
295                   ((and line (pred stringp)
296                         (guard (not (string-match-p "\\`\n?\\'" line))))
297                    (car (split-string line "[\n\r]")))
298                   (_ "<EMPTY LINE>"))))
299       (remove-text-properties 0 (length line) '(read-only) line)
300       (format "%7d:%s:    %s"
301               (line-number-at-pos) (marker-buffer marker) line))))
302
303 (defun helm-global-mark-ring-get-candidates ()
304   (let ((marks global-mark-ring))
305     (when marks
306       (cl-loop for marker in marks
307                for mb = (marker-buffer marker)
308                for gm = (unless (or (string-match "^ " (format "%s" mb))
309                                     (null mb))
310                           (helm-global-mark-ring-format-buffer marker))
311                when (and gm (not (assoc gm recip)))
312                collect (cons gm marker) into recip
313                finally return recip))))
314
315 ;;;; <Register>
316 ;;; Insert from register
317 (defvar helm-source-register
318   (helm-build-sync-source "Registers"
319     :candidates #'helm-register-candidates
320     :action-transformer #'helm-register-action-transformer
321     :persistent-help ""
322     :multiline t
323     :action '(("Delete Register(s)" .
324                (lambda (_candidate)
325                  (cl-loop for candidate in (helm-marked-candidates)
326                           for register = (car candidate)
327                           do (setq register-alist
328                                 (delq (assoc register register-alist)
329                                       register-alist))))))
330     :group 'helm-ring)
331   "See (info \"(emacs)Registers\")")
332
333 (defun helm-register-candidates ()
334   "Collecting register contents and appropriate commands."
335   (cl-loop for (char . val) in register-alist
336         for key    = (single-key-description char)
337         for string-actions =
338         (cond
339           ((numberp val)
340            (list (int-to-string val)
341                  'insert-register
342                  'increment-register))
343           ((markerp val)
344            (let ((buf (marker-buffer val)))
345              (if (null buf)
346                  (list "a marker in no buffer")
347                (list (concat
348                       "a buffer position:"
349                       (buffer-name buf)
350                       ", position "
351                       (int-to-string (marker-position val)))
352                      'jump-to-register
353                      'insert-register))))
354           ((and (consp val) (window-configuration-p (car val)))
355            (list "window configuration."
356                  'jump-to-register))
357           ((and (vectorp val)
358                 (fboundp 'undo-tree-register-data-p)
359                 (undo-tree-register-data-p (elt val 1)))
360            (list
361             "Undo-tree entry."
362             'undo-tree-restore-state-from-register))
363           ((or (and (vectorp val) (eq 'registerv (aref val 0)))
364                (and (consp val) (frame-configuration-p (car val))))
365            (list "frame configuration."
366                  'jump-to-register))
367           ((and (consp val) (eq (car val) 'file))
368            (list (concat "file:"
369                          (prin1-to-string (cdr val))
370                          ".")
371                  'jump-to-register))
372           ((and (consp val) (eq (car val) 'file-query))
373            (list (concat "file:a file-query reference: file "
374                          (car (cdr val))
375                          ", position "
376                          (int-to-string (car (cdr (cdr val))))
377                          ".")
378                  'jump-to-register))
379           ((consp val)
380            (let ((lines (format "%4d" (length val))))
381              (list (format "%s: %s\n" lines
382                            (truncate-string-to-width
383                             (mapconcat 'identity (list (car val))
384                                        "^J") (- (window-width) 15)))
385                    'insert-register)))
386           ((stringp val)
387            (list
388             ;; without properties
389             (concat (substring-no-properties
390                      val 0 (min (length val) helm-register-max-offset))
391                     (if (> (length val) helm-register-max-offset)
392                         "[...]" ""))
393             'insert-register
394             'append-to-register
395             'prepend-to-register)))
396         unless (null string-actions) ; Fix Issue #1107.
397         collect (cons (format "Register %3s:\n %s" key (car string-actions))
398                       (cons char (cdr string-actions)))))
399
400 (defun helm-register-action-transformer (actions register-and-functions)
401   "Decide actions by the contents of register."
402   (cl-loop with func-actions =
403            '((insert-register
404               "Insert Register" .
405               (lambda (c) (insert-register (car c))))
406              (jump-to-register
407               "Jump to Register" .
408               (lambda (c) (jump-to-register (car c))))
409              (append-to-register
410               "Append Region to Register" .
411               (lambda (c) (append-to-register
412                            (car c) (region-beginning) (region-end))))
413              (prepend-to-register
414               "Prepend Region to Register" .
415               (lambda (c) (prepend-to-register
416                            (car c) (region-beginning) (region-end))))
417              (increment-register
418               "Increment Prefix Arg to Register" .
419               (lambda (c) (increment-register
420                            helm-current-prefix-arg (car c))))
421              (undo-tree-restore-state-from-register
422               "Restore Undo-tree register" .
423               (lambda (c) (and (fboundp 'undo-tree-restore-state-from-register)
424                                (undo-tree-restore-state-from-register (car c))))))
425            for func in (cdr register-and-functions)
426            when (assq func func-actions)
427            collect (cdr it) into transformer-actions
428            finally return (append transformer-actions actions)))
429
430 ;;;###autoload
431 (defun helm-mark-ring ()
432   "Preconfigured `helm' for `helm-source-mark-ring'."
433   (interactive)
434   (helm :sources 'helm-source-mark-ring
435         :resume 'noresume
436         :buffer "*helm mark*"))
437
438 ;;;###autoload
439 (defun helm-global-mark-ring ()
440   "Preconfigured `helm' for `helm-source-global-mark-ring'."
441   (interactive)
442   (helm :sources 'helm-source-global-mark-ring
443         :resume 'noresume
444         :buffer "*helm global mark*"))
445
446 ;;;###autoload
447 (defun helm-all-mark-rings ()
448   "Preconfigured `helm' for `helm-source-global-mark-ring' and \
449 `helm-source-mark-ring'."
450   (interactive)
451   (helm :sources '(helm-source-mark-ring
452                    helm-source-global-mark-ring)
453         :resume 'noresume
454         :buffer "*helm mark ring*"))
455
456 ;;;###autoload
457 (defun helm-register ()
458   "Preconfigured `helm' for Emacs registers."
459   (interactive)
460   (helm :sources 'helm-source-register
461         :resume 'noresume
462         :buffer "*helm register*"))
463
464 ;;;###autoload
465 (defun helm-show-kill-ring ()
466   "Preconfigured `helm' for `kill-ring'.
467 It is drop-in replacement of `yank-pop'.
468
469 First call open the kill-ring browser, next calls move to next line."
470   (interactive)
471   (setq helm-kill-ring--truncated-flag nil)
472   (let ((enable-recursive-minibuffers t))
473     (helm :sources helm-source-kill-ring
474           :buffer "*helm kill ring*"
475           :resume 'noresume
476           :allow-nest t)))
477
478 ;;;###autoload
479 (defun helm-execute-kmacro ()
480   "Preconfigured helm for keyboard macros.
481 Define your macros with `f3' and `f4'.
482 See (info \"(emacs) Keyboard Macros\") for detailed infos.
483 This command is useful when used with persistent action."
484   (interactive)
485   (let ((helm-quit-if-no-candidate
486          (lambda () (message "No kbd macro has been defined"))))
487     (helm :sources
488           (helm-build-sync-source "Kmacro"
489             :candidates (lambda ()
490                           (helm-fast-remove-dups
491                            (cons (kmacro-ring-head)
492                                  kmacro-ring)
493                            :test 'equal))
494             :multiline t
495             :candidate-transformer
496             (lambda (candidates)
497               (cl-loop for c in candidates collect
498                        (propertize (help-key-description (car c) nil)
499                                    'helm-realvalue c)))
500             :persistent-help "Execute kmacro"
501             :help-message 'helm-kmacro-help-message
502             :action
503             (helm-make-actions
504              "Execute kmacro (`C-u <n>' to execute <n> times)"
505              'helm-kbd-macro-execute
506              "Concat marked macros"
507              'helm-kbd-macro-concat-macros
508              "Delete marked macros"
509              'helm-kbd-macro-delete-macro
510              "Edit marked macro"
511              'helm-kbd-macro-edit-macro)
512             :group 'helm-ring)
513           :buffer "*helm kmacro*")))
514
515 (defun helm-kbd-macro-execute (candidate)
516   ;; Move candidate on top of list for next use.
517   (setq kmacro-ring (delete candidate kmacro-ring))
518   (kmacro-push-ring)
519   (kmacro-split-ring-element candidate)
520   (kmacro-exec-ring-item
521    candidate helm-current-prefix-arg))
522
523 (defun helm-kbd-macro-concat-macros (_candidate)
524   (let ((mkd (helm-marked-candidates)))
525     (when (cdr mkd)
526       (kmacro-push-ring)
527       (setq last-kbd-macro
528             (mapconcat 'identity
529                        (cl-loop for km in mkd
530                                 if (vectorp km)
531                                 append (cl-loop for k across km collect
532                                                 (key-description (vector k)))
533                                 into result
534                                 else collect (car km) into result
535                                 finally return result)
536                        "")))))
537
538 (defun helm-kbd-macro-delete-macro (_candidate)
539   (let ((mkd (helm-marked-candidates)))
540     (kmacro-push-ring)
541     (cl-loop for km in mkd
542              do (setq kmacro-ring (delete km kmacro-ring)))
543     (kmacro-pop-ring1)))
544
545 (defun helm-kbd-macro-edit-macro (candidate)
546   (kmacro-push-ring)
547   (setq kmacro-ring (delete candidate kmacro-ring))
548   (kmacro-split-ring-element candidate)
549   (kmacro-edit-macro))
550
551 (provide 'helm-ring)
552
553 ;; Local Variables:
554 ;; byte-compile-warnings: (not obsolete)
555 ;; coding: utf-8
556 ;; indent-tabs-mode: nil
557 ;; End:
558
559 ;;; helm-ring.el ends here