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