summary refs log tree commit diff stats
path: root/lisp/acdw-compat.el
blob: 04e42aea88d3cb1c8ac3244a7723b916c903e139 (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
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
;;; 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 macro
(defmacro safe-define (&rest defines)
  "Wrap DEFINES in tests to make sure they're not already defined.
Is it necessary?  Who knows!!"
  (let (output)
    (dolist (form defines)
      (let ((test (cond ((memq (car form)
                               '(define-global-minor-mode
                                  define-globalized-minor-mode
                                  define-minor-mode
                                  defmacro
                                  defsubst
                                  defun))
                         #'fboundp)
                        ((memq (car form)
                               '(defcustom
                                  defvar
                                  defvar
                                  defvar-local
                                  defvar-mode-local
                                  defvaralias))
                         #'boundp))))
        (push (if test
                  `(unless (,test ',(cadr form))
                     ,form)
                form)
              output)))
    `(progn ,@(nreverse output))))


;;; Functions for changing capitalization that Do What I Mean
;; Defined in EMACS/lisp/simple.el
(safe-define
 (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)))

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

 (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-define
 (defcustom repeat-too-dangerous '(kill-this-buffer)
   "Commands too dangerous to repeat with \\[repeat]."
   :group 'convenience
   :type '(repeat function))

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

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

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

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

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

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

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

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

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

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

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

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

 (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'.")

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

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

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

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

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

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

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

;;; Bindings!
 (defvar undo-repeat-map
   (let ((map (make-sparse-keymap)))
     (define-key map "u" 'undo)
     map)
   "Keymap to repeat undo key sequences `C-x u u'.  Used in `repeat-mode'.")
 (put 'undo 'repeat-map 'undo-repeat-map)

 (defvar next-error-repeat-map
   (let ((map (make-sparse-keymap)))
     (define-key map    "n" 'next-error)
     (define-key map "\M-n" 'next-error)
     (define-key map    "p" 'previous-error)
     (define-key map "\M-p" 'previous-error)
     map)
   "Keymap to repeat next-error key sequences.  Used in `repeat-mode'.")
 (put 'next-error 'repeat-map 'next-error-repeat-map)
 (put 'previous-error 'repeat-map 'next-error-repeat-map)

 (defvar page-navigation-repeat-map
   (let ((map (make-sparse-keymap)))
     (define-key map "]" #'forward-page)
     (define-key map "[" #'backward-page)
     map)
   "Keymap to repeat page navigation key sequences.  Used in `repeat-mode'.") 
 (put 'forward-page 'repeat-map 'page-navigation-repeat-map)
 (put 'backward-page 'repeat-map 'page-navigation-repeat-map)

 (defvar tab-bar-switch-repeat-map
   (let ((map (make-sparse-keymap)))
     (define-key map "o" 'tab-next)
     (define-key map "O" 'tab-previous)
     map)
   "Keymap to repeat tab switch key sequences `C-x t o o O'.
Used in `repeat-mode'.")
 (put 'tab-next 'repeat-map 'tab-bar-switch-repeat-map)
 (put 'tab-previous 'repeat-map 'tab-bar-switch-repeat-map)

 (defvar tab-bar-move-repeat-map
   (let ((map (make-sparse-keymap)))
     (define-key map "m" 'tab-move)
     (define-key map "M" (lambda ()
                           (interactive)
                           (setq repeat-map 'tab-bar-move-repeat-map)
                           (tab-move -1)))
     map)
   "Keymap to repeat tab move key sequences `C-x t m m M'.
Used in `repeat-mode'.")
 (put 'tab-move 'repeat-map 'tab-bar-move-repeat-map)

 (defvar other-window-repeat-map
   (let ((map (make-sparse-keymap)))
     (define-key map "o" 'other-window)
     (define-key map "O" (lambda ()
                           (interactive)
                           (setq repeat-map 'other-window-repeat-map)
                           (other-window -1)))
     map)
   "Keymap to repeat other-window key sequences.  Used in `repeat-mode'.")
 (put 'other-window 'repeat-map 'other-window-repeat-map)

 (defvar resize-window-repeat-map
   (let ((map (make-sparse-keymap)))
     ;; Standard keys:
     (define-key map "^" 'enlarge-window)
     (define-key map "}" 'enlarge-window-horizontally)
     (define-key map "{" 'shrink-window-horizontally)
     ;; Additional keys:
     (define-key map "v" 'shrink-window)
     map)
   "Keymap to repeat window resizing commands.  Used in `repeat-mode'.")
 (put 'enlarge-window 'repeat-map 'resize-window-repeat-map)
 (put 'enlarge-window-horizontally 'repeat-map 'resize-window-repeat-map)
 (put 'shrink-window-horizontally 'repeat-map 'resize-window-repeat-map)
 (put 'shrink-window 'repeat-map 'resize-window-repeat-map)

 (defvar outline-navigation-repeat-map
   (let ((map (make-sparse-keymap)))
     (define-key map (kbd "C-b") #'outline-backward-same-level)
     (define-key map (kbd "b") #'outline-backward-same-level)
     (define-key map (kbd "C-f") #'outline-forward-same-level)
     (define-key map (kbd "f") #'outline-forward-same-level)
     (define-key map (kbd "C-n") #'outline-next-visible-heading)
     (define-key map (kbd "n") #'outline-next-visible-heading)
     (define-key map (kbd "C-p") #'outline-previous-visible-heading)
     (define-key map (kbd "p") #'outline-previous-visible-heading)
     (define-key map (kbd "C-u") #'outline-up-heading)
     (define-key map (kbd "u") #'outline-up-heading)
     map))
 
 (defvar outline-editing-repeat-map
   (let ((map (make-sparse-keymap)))
     (define-key map (kbd "C-v") #'outline-move-subtree-down)
     (define-key map (kbd "v") #'outline-move-subtree-down)
     (define-key map (kbd "C-^") #'outline-move-subtree-up)
     (define-key map (kbd "^") #'outline-move-subtree-up)
     (define-key map (kbd "C->") #'outline-demote)
     (define-key map (kbd ">") #'outline-demote)
     (define-key map (kbd "C-<") #'outline-promote)
     (define-key map (kbd "<") #'outline-promote)
     map))

 (with-eval-after-load 'outline
   (dolist (command '(outline-backward-same-level
                      outline-forward-same-level
                      outline-next-visible-heading
                      outline-previous-visible-heading
                      outline-up-heading))
     (put command 'repeat-map 'outline-navigation-repeat-map))

   (dolist (command '(outline-move-subtree-down
                      outline-move-subtree-up
                      outline-demote
                      outline-promote))
     (put command 'repeat-map 'outline-editing-repeat-map))))


;;; goto-address-mode
(safe-define
 (defvar global-address-mode nil)
 
 (define-globalized-minor-mode global-goto-address-mode
   goto-address-mode goto-addr-mode--turn-on
   :version "28.1")

 (defun goto-addr-mode--turn-on ()
   (when (not goto-address-mode)
     (goto-address-mode 1))))

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