summary refs log tree commit diff stats
path: root/lisp/acdw-compat.el
blob: 2ce88988af3cec945541ce6ea25b6ce2ce9cc754 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
;;; acdw-compat.el -*- lexical-binding: t; coding: utf-8-unix -*-

;; Author: Case Duckworth <acdw@acdw.net>
;; Created: 2021-08-11
;; Keywords: configuration
;; URL: https://tildegit.org/acdw/emacs

;; This file is NOT part of GNU Emacs.

;;; License:
;; Everyone is permitted to do whatever with this software, without
;; limitation.  This software comes without any warranty whatsoever,
;; but with two pieces of advice:
;; - Don't hurt yourself.
;; - Make good choices.

;;; Commentary:

;; This file contains functions, variables, and other code that might not be in
;; every version of Emacs I use.

;;; Code:

;; Convenience macros
(defmacro safe-defun (name arglist &rest body)
  "Like `defun', but only if the function doesn't already exist.

Is it necessary?  Who knows!

\(fn NAME ARGLIST &optional DOCSTRING DECL &rest BODY)"
  (declare (doc-string 3)
           (indent 2))
  `(unless (fboundp (function ,name))
     (defun ,name ,arglist ,@body)))

(defmacro safe-defsubst (name arglist &rest body)
  "Like `defsubst', but only if the inline function doesn't exist.
\(fn NAME ARGLIST &optional DOCSTRING DECL &rest BODY"
  (declare (debug defun) (doc-string 3))
  `(unless (fboundp (function ,name))
     (defsubst ,name ,arglist ,@body)))

(defmacro safe-define-minor-mode (mode doc &rest body)
  "Like `define-minor-mode', but only if the mode doesn't exist.
\(fn MODE DOC &optional INIT-VALUE LIGHTER KEYMAP &rest BODY)"
  (declare (doc-string 2)
           (debug (&define name string-or-null-p
                           [&optional [&not keywordp] sexp
                                      &optional [&not keywordp] sexp
                                      &optional [&not keywordp] sexp]
                           [&rest [keywordp sexp]]
                           def-body)))
  `(unless (fboundp (function ,mode))
     (define-minor-mode ,mode ,doc ,@body)))

(defmacro safe-defvar (symbol &optional initvalue docstring)
  "Like `defvar', but only if the variable doesn't already exist."
  (declare (doc-string 3)
           (indent 2))
  `(unless (boundp (quote ,symbol))
     (defvar ,symbol ,initvalue ,docstring)))

(defmacro safe-defcustom (symbol standard doc &rest args)
  "Like `defcustom', but only if the variable doesn't already exist."
  (declare (doc-string 3)
           (debug (name body)))
  `(unless (boundp (quote ,symbol))
     (defcustom ,symbol ,standard ,doc ,@args)))


;;; Functions for changing capitalization that Do What I Mean
;; Defined in EMACS/lisp/simple.el

(safe-defun upcase-dwim (arg)
  "Upcase words in the region, if active; if not, upcase word at point.
If the region is active, this function calls `upcase-region'.
Otherwise, it calls `upcase-word', with prefix argument passed to it
to upcase ARG words."
  (interactive "*p")
  (if (use-region-p)
      (upcase-region (region-beginning) (region-end) (region-noncontiguous-p))
    (upcase-word arg)))

(safe-defun downcase-dwim (arg)
  "Downcase words in the region, if active; if not, downcase word at point.
If the region is active, this function calls `downcase-region'.
Otherwise, it calls `downcase-word', with prefix argument passed to it
to downcase ARG words."
  (interactive "*p")
  (if (use-region-p)
      (downcase-region (region-beginning) (region-end) (region-noncontiguous-p))
    (downcase-word arg)))

(safe-defun capitalize-dwim (arg)
  "Capitalize words in the region, if active; if not, capitalize word at point.
If the region is active, this function calls `capitalize-region'.
Otherwise, it calls `capitalize-word', with prefix argument passed to it
to capitalize ARG words."
  (interactive "*p")
  (if (use-region-p)
      (capitalize-region (region-beginning) (region-end) (region-noncontiguous-p))
    (capitalize-word arg)))


;;; Repeat.el
;; Defined in EMACS/lisp/repeat.el

(safe-defcustom repeat-too-dangerous '(kill-this-buffer)
                "Commands too dangerous to repeat with \\[repeat]."
                :group 'convenience
                :type '(repeat function))

(safe-defvar repeat-message-function nil
  "If non-nil, function used by `repeat' command to say what it's doing.
Message is something like \"Repeating command glorp\".
A value of `ignore' will disable such messages.  To customize
display, assign a function that takes one string as an arg and
displays it however you want.
If this variable is nil, the normal `message' function will be
used to display the messages.")

(safe-defcustom repeat-on-final-keystroke t
                "Allow `repeat' to re-execute for repeating lastchar of a key sequence.
If this variable is t, `repeat' determines what key sequence
it was invoked by, extracts the final character of that sequence, and
re-executes as many times as that final character is hit; so for example
if `repeat' is bound to C-x z, typing C-x z z z repeats the previous command
3 times.  If this variable is a sequence of characters, then re-execution
only occurs if the final character by which `repeat' was invoked is a
member of that sequence.  If this variable is nil, no re-execution occurs."
                :group 'convenience
                :type '(choice (const :tag "Repeat for all keys" t)
                               (const :tag "Don't repeat" nil)
                               (sexp :tag "Repeat for specific keys")))

(safe-defvar repeat-num-input-keys-at-repeat -1
  "# key sequences read in Emacs session when `repeat' last invoked.")

(safe-defsubst repeat-is-really-this-command ()
               "Return t if this command is happening because user invoked `repeat'.
Usually, when a command is executing, the Emacs builtin variable
`this-command' identifies the command the user invoked.  Some commands modify
that variable on the theory they're doing more good than harm; `repeat' does
that, and usually does do more good than harm.  However, like all do-gooders,
sometimes `repeat' gets surprising results from its altruism.  The value of
this function is always whether the value of `this-command' would've been
'repeat if `repeat' hadn't modified it."
               (= repeat-num-input-keys-at-repeat num-input-keys))

(safe-defvar repeat-previous-repeated-command nil
  "The previous repeated command.")

;;;###autoload
(safe-defun repeat (repeat-arg)
  "Repeat most recently executed command.
If REPEAT-ARG is non-nil (interactively, with a prefix argument),
supply a prefix argument to that command.  Otherwise, give the
command the same prefix argument it was given before, if any.

If this command is invoked by a multi-character key sequence, it
can then be repeated by repeating the final character of that
sequence.  This behavior can be modified by the global variable
`repeat-on-final-keystroke'.

`repeat' ignores commands bound to input events.  Hence the term
\"most recently executed command\" shall be read as \"most
recently executed command not bound to an input event\"."
  ;; The most recently executed command could be anything, so surprises could
  ;; result if it were re-executed in a context where new dynamically
  ;; localized variables were shadowing global variables in a `let' clause in
  ;; here.  (Remember that GNU Emacs 19 is dynamically localized.)
  ;; To avoid that, I tried the `lexical-let' of the Common Lisp extensions,
  ;; but that entails a very noticeable performance hit, so instead I use the
  ;; "repeat-" prefix, reserved by this package, for *local* variables that
  ;; might be visible to re-executed commands, including this function's arg.
  (interactive "P")
  (when (eq last-repeatable-command 'repeat)
    (setq last-repeatable-command repeat-previous-repeated-command))
  (cond
   ((null last-repeatable-command)
    (error "There is nothing to repeat"))
   ((eq last-repeatable-command 'mode-exit)
    (error "last-repeatable-command is mode-exit & can't be repeated"))
   ((memq last-repeatable-command repeat-too-dangerous)
    (error "Command %S too dangerous to repeat automatically"
           last-repeatable-command)))
  (setq this-command last-repeatable-command
        repeat-previous-repeated-command last-repeatable-command
        repeat-num-input-keys-at-repeat num-input-keys)
  (when (null repeat-arg)
    (setq repeat-arg last-prefix-arg))
  ;; Now determine whether to loop on repeated taps of the final character
  ;; of the key sequence that invoked repeat.  The Emacs global
  ;; last-command-event contains the final character now, but may not still
  ;; contain it after the previous command is repeated, so the character
  ;; needs to be saved.
  (let ((repeat-repeat-char
         (if (eq repeat-on-final-keystroke t)
             last-command-event
           ;; Allow only specified final keystrokes.
           (car (memq last-command-event
                      (listify-key-sequence
                       repeat-on-final-keystroke))))))
    (if (eq last-repeatable-command (caar command-history))
        (let ((repeat-command (car command-history)))
          (repeat-message "Repeating %S" repeat-command)
          (eval repeat-command))
      (if (null repeat-arg)
          (repeat-message "Repeating command %S" last-repeatable-command)
        (setq current-prefix-arg repeat-arg)
        (repeat-message
         "Repeating command %S %S" repeat-arg last-repeatable-command))
      (when (eq last-repeatable-command 'self-insert-command)
        ;; We used to use a much more complex code to try and figure out
        ;; what key was used to run that self-insert-command:
        ;; (if (<= (- num-input-keys
        ;;            repeat-num-input-keys-at-self-insert)
        ;;         1)
        ;;     repeat-last-self-insert
        ;;   (let ((range (nth 1 buffer-undo-list)))
        ;;     (condition-case nil
        ;;         (setq repeat-last-self-insert
        ;;               (buffer-substring (car range)
        ;;                                 (cdr range)))
        ;;       (error (error "%s %s %s"  ;Danger, Will Robinson!
        ;;                     "repeat can't intuit what you"
        ;;                     "inserted before auto-fill"
        ;;                     "clobbered it, sorry")))))
        (setq last-command-event (char-before)))
      (let ((indirect (indirect-function last-repeatable-command)))
        (if (or (stringp indirect)
                (vectorp indirect))
            ;; Bind last-repeatable-command so that executing the macro does
            ;; not alter it.
            (let ((last-repeatable-command last-repeatable-command))
              (execute-kbd-macro last-repeatable-command))
          (call-interactively last-repeatable-command))))
    (when repeat-repeat-char
      (set-transient-map
       (let ((map (make-sparse-keymap)))
         (define-key map (vector repeat-repeat-char)
           (if (null repeat-message-function) 'repeat
             ;; If repeat-message-function is let-bound, preserve it for the
             ;; next "iterations of the loop".
             (let ((fun repeat-message-function))
               (lambda ()
                 (interactive)
                 (let ((repeat-message-function fun))
                   (setq this-command 'repeat)
                   ;; Beware: messing with `real-this-command' is *bad*, but we
                   ;; need it so `last-repeatable-command' can be recognized
                   ;; later (bug#12232).
                   (setq real-this-command 'repeat)
                   (call-interactively 'repeat))))))
         map)))))

(safe-defun repeat-message (format &rest args)
  "Like `message' but displays with `repeat-message-function' if non-nil."
  (let ((message (apply 'format format args)))
    (if repeat-message-function
        (funcall repeat-message-function message)
      (message "%s" message))))

(safe-defcustom repeat-exit-key nil
                "Key that stops the modal repeating of keys in sequence.
For example, you can set it to <return> like `isearch-exit'."
                :type '(choice (const :tag "No special key to exit repeating sequence" nil)
                               (key-sequence :tag "Key that exits repeating sequence"))
                :group 'convenience
                :version "28.1")

(safe-defcustom repeat-exit-timeout nil
                "Break the repetition chain of keys after specified timeout.
When a number, exit the repeat mode after idle time of the specified
number of seconds."
                :type '(choice (const :tag "No timeout to exit repeating sequence" nil)
                               (number :tag "Timeout in seconds to exit repeating"))
                :group 'convenience
                :version "28.1")

(safe-defvar repeat-exit-timer nil
  "Timer activated after the last key typed in the repeating key sequence.")

(defcustom repeat-keep-prefix t
  "Keep the prefix arg of the previous command."
  :type 'boolean
  :group 'convenience
  :version "28.1")

(safe-defcustom repeat-echo-function #'repeat-echo-message
                "Function to display a hint about available keys.
Function is called after every repeatable command with one argument:
a repeating map, or nil after deactivating the repeat mode."
                :type '(choice (const :tag "Show hints in the echo area"
                                      repeat-echo-message)
                               (const :tag "Show indicator in the mode line"
                                      repeat-echo-mode-line)
                               (const :tag "No visual feedback" ignore)
                               (function :tag "Function"))
                :group 'convenience
                :version "28.1")

(safe-defvar repeat-in-progress nil
  "Non-nil when the repeating map is active.")

;;;###autoload
(safe-defvar repeat-map nil
  "The value of the repeating map for the next command.
A command called from the map can set it again to the same map when
the map can't be set on the command symbol property `repeat-map'.")

;;;###autoload
(safe-define-minor-mode repeat-mode
                        "Toggle Repeat mode.
When Repeat mode is enabled, and the command symbol has the property named
`repeat-map', this map is activated temporarily for the next command."
                        :global t :group 'convenience
                        (if (not repeat-mode)
                            (remove-hook 'post-command-hook 'repeat-post-hook)
                          (add-hook 'post-command-hook 'repeat-post-hook)
                          (let* ((keymaps nil)
                                 (commands (all-completions
                                            "" obarray (lambda (s)
                                                         (and (commandp s)
                                                              (get s 'repeat-map)
                                                              (push (get s 'repeat-map) keymaps))))))
                            (message "Repeat mode is enabled for %d commands and %d keymaps; see `describe-repeat-maps'."
                                     (length commands)
                                     (length (delete-dups keymaps))))))

(safe-defun repeat-post-hook ()
  "Function run after commands to set transient keymap for repeatable keys."
  (let ((was-in-progress repeat-in-progress))
    (setq repeat-in-progress nil)
    (when repeat-mode
      (let ((rep-map (or repeat-map
                         (and (symbolp real-this-command)
                              (get real-this-command 'repeat-map)))))
        (when rep-map
          (when (boundp rep-map)
            (setq rep-map (symbol-value rep-map)))
          (let ((map (copy-keymap rep-map)))

            ;; Exit when the last char is not among repeatable keys,
            ;; so e.g. `C-x u u' repeats undo, whereas `C-/ u' doesn't.
            (when (and (zerop (minibuffer-depth)) ; avoid remapping in prompts
                       (or (lookup-key map (this-command-keys-vector))
                           prefix-arg))

              ;; Messaging
              (unless prefix-arg
                (funcall repeat-echo-function map))

              ;; Adding an exit key
              (when repeat-exit-key
                (define-key map repeat-exit-key 'ignore))

              (when (and repeat-keep-prefix (not prefix-arg))
                (setq prefix-arg current-prefix-arg))

              (setq repeat-in-progress t)
              (let ((exitfun (set-transient-map map)))

                (when repeat-exit-timer
                  (cancel-timer repeat-exit-timer)
                  (setq repeat-exit-timer nil))

                (when repeat-exit-timeout
                  (setq repeat-exit-timer
                        (run-with-idle-timer
                         repeat-exit-timeout nil
                         (lambda ()
                           (setq repeat-in-progress nil)
                           (funcall exitfun)
                           (funcall repeat-echo-function nil)))))))))))

    (setq repeat-map nil)
    (when (and was-in-progress (not repeat-in-progress))
      (when repeat-exit-timer
        (cancel-timer repeat-exit-timer)
        (setq repeat-exit-timer nil))
      (funcall repeat-echo-function nil))))

(safe-defun repeat-echo-message-string (keymap)
  "Return a string with a list of repeating keys."
  (let (keys)
    (map-keymap (lambda (key _) (push key keys)) keymap)
    (format-message "Repeat with %s%s"
                    (mapconcat (lambda (key)
                                 (key-description (vector key)))
                               keys ", ")
                    (if repeat-exit-key
                        (format ", or exit with %s"
                                (key-description repeat-exit-key))
                      ""))))

(safe-defun repeat-echo-message (keymap)
  "Display available repeating keys in the echo area."
  (if keymap
      (let ((mess (repeat-echo-message-string keymap)))
        (if (current-message)
            (message "%s [%s]" (current-message) mess)
          (message mess)))
    (and (current-message)
         (string-search "Repeat with " (current-message))
         (message nil))))

(safe-defvar repeat-echo-mode-line-string
    (propertize "[Repeating...] " 'face 'mode-line-emphasis)
  "String displayed in the mode line in repeating mode.")

(safe-defun repeat-echo-mode-line (keymap)
  "Display the repeat indicator in the mode line."
  (if keymap
      (unless (assq 'repeat-in-progress mode-line-modes)
        (add-to-list 'mode-line-modes (list 'repeat-in-progress
                                            repeat-echo-mode-line-string)))
    (force-mode-line-update t)))

(safe-defun describe-repeat-maps ()
  "Describe mappings of commands repeatable by symbol property `repeat-map'."
  (interactive)
  (help-setup-xref (list #'describe-repeat-maps)
                   (called-interactively-p 'interactive))
  (let ((keymaps nil))
    (all-completions
     "" obarray (lambda (s)
                  (and (commandp s)
                       (get s 'repeat-map)
                       (push s (alist-get (get s 'repeat-map) keymaps)))))
    (with-help-window (help-buffer)
      (with-current-buffer standard-output
        (princ "A list of keymaps used by commands with the symbol property `repeat-map'.\n\n")

        (dolist (keymap (sort keymaps (lambda (a b) (string-lessp (car a) (car b)))))
          (princ (format-message "`%s' keymap is repeatable by these commands:\n"
                                 (car keymap)))
          (dolist (command (sort (cdr keymap) 'string-lessp))
            (princ (format-message " `%s'\n" command)))
          (princ "\n"))))))


(provide 'acdw-compat)
;;; acdw-compat.el ends here