path: root/lisp/acdw-compat.el

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

;;; Bindings!
(safe-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)


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


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


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

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


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

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


(with-eval-after-load 'outline
  (safe-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))

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

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

  (dolist (command '(outline-move-subtree-down
                     outline-move-subtree-up
                     outline-demote
                     outline-promote))
    (put command 'repeat-map 'outline-editing-repeat-map))
  )

(provide 'acdw-compat)
;;; acdw-compat.el ends here