emacs/lisp/acdw-compat.el

556 lines
23 KiB
EmacsLisp
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;; 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 safely (&rest defines)
"Wrap DEFINES in tests to make sure they're not already defined.
Is it necessary? Who knows!!"
(let (output)
(dolist (form defines)
;; this is one part where elisp being a lisp-2 bites us...
(push (cond ((memq (car form)
'(;; makes functions
define-global-minor-mode
define-globalized-minor-mode
define-minor-mode
defmacro
defsubst
defun))
`(unless (fboundp ',(cadr form))
,form))
((memq (car form)
'(;; makes variables
defcustom
defvar
defvar
defvar-local
defvar-mode-local
defvaralias))
`(unless (boundp ',(cadr form))
,form))
(t form))
output))
`(progn ,@(nreverse output))))
;;; Functions for changing capitalization that Do What I Mean
;; Defined in EMACS/lisp/simple.el
(safely
(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
(safely
(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
(safely
(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