path: root/lisp/acdw.el

;;; acdw.el --- miscellaneous    -*- lexical-binding: t; coding: utf-8-unix -*-

;; Author: Case Duckworth <(rot13-string "npqj@npqj.arg")>
;; Created: Sometime during Covid-19, 2020
;; 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:
;; `acdw.el' contains `acdw/map', its mode, and assorted ease-of-life
;; functions for me, acdw.

;;; Code:

(require 'cl-lib)
(require 'auth-source)
(require 'recentf)

;;; Variables

(defconst acdw/system
  (pcase system-type
    ('gnu/linux :home)
    ((or 'msdos 'windows-nt) :work)
    (_ :other))
  "Which computer system is currently being used.")

(defmacro acdw/system (&rest args)
  "Macro for interfacing, depending on ARGS, with symbol `acdw/system'.

When called without arguments, it returns symbol `acdw/system'.  When
called with one (symbol) argument, it returns (eq acdw/system
ARG).  When called with multiple arguments or a list, it returns
`pcase' over each argument."
  (cond
   ((null args) acdw/system)
   ((atom (car args))
    `(when (eq acdw/system ,(car args))
       ,(car args)))
   (t
    `(pcase acdw/system
       ,@args))))


;;; Utility functions
;; I don't prefix these because ... reasons.  Honestly I probably should prefix
;; them.

(defun truncate-string (len str &optional ellipsis)
  "If STR is longer than LEN, cut it down and add ELLIPSIS to the end.
When not specified, ELLIPSIS defaults to '...'."
  (declare (pure t) (side-effect-free t))
  (unless ellipsis
    (setq ellipsis "..."))
  (if (> (length str) len)
      (format "%s%s" (substring str 0 (- len (length ellipsis))) ellipsis)
    str))

;; Why isn't this a thing???
(defmacro fbound-and-true-p (func)
  "Return the value of function FUNC if it is bound, else nil."
  `(and (fboundp ,func) ,func))

(defmacro when-unfocused (name &rest forms)
  "Define a function NAME, executing FORMS, for when Emacs is unfocused."
  (declare (indent 1))
  (let ((func-name (intern (concat "when-unfocused-" (symbol-name name)))))
    `(progn
       (defun ,func-name () "Defined by `when-unfocused'."
              (when (seq-every-p #'null
                                 (mapcar #'frame-focus-state (frame-list)))
                ,@forms))
       (add-function :after after-focus-change-function #',func-name))))

(defmacro with-eval-after-loads (features &rest body)
  "Execute BODY after FEATURES are loaded.
This macro simplifies `with-eval-after-load' for multiple nested
features."
  (declare (indent 1)
           (debug (form def-body)))
  (unless (listp features)
    (setq features (list features)))
  (if (null features)
      (macroexp-progn body)
    (let* ((this (car features))
           (rest (cdr features)))
      `(with-eval-after-load ',this
         (with-eval-after-loads ,rest ,@body)))))

(defmacro with-message (message &rest body)
  "Execute BODY, messaging 'MESSAGE...' before and 'MESSAGE... Done.' after."
  (declare (indent 1))
  ;; Wrap a progn inside a prog1 to return the return value of the body.
  `(prog1
       (progn (message "%s..." ,message)
              ,@body)
     (message "%s... Done." ,message)))

(defun clone-buffer-write-file (filename &optional confirm)
  "Clone current buffer to a file named FILENAME and switch.
FILENAME and CONFIRM are passed directly to `write-file'."
  (interactive                          ; stolen from `write-file'
   (list (if buffer-file-name
             (read-file-name "Write file: "
                             nil nil nil nil)
           (read-file-name "Write file: " default-directory
                           (expand-file-name
                            (file-name-nondirectory (buffer-name))
                            default-directory)
                           nil nil))
         (not current-prefix-arg)))
  (let ((buf (clone-buffer nil nil)))
    (with-current-buffer buf
      (write-file filename confirm))
    (switch-to-buffer buf)))

;; https://old.reddit.com/r/emacs/comments/pjwkts
(defun acdw/goto-last-row ()
  "Move point to last row of buffer, but save the column."
  (interactive)
  (let ((col (current-column)))
    (goto-char (point-max))
    (move-to-column col t)))

(defun acdw/goto-first-row ()
  "Move point to first row of buffer, but save the column."
  (interactive)
  (let ((col (current-column)))
    (goto-char (point-min))
    (move-to-column col t)))

(defun dos2unix (buffer)
  "Replace \r\n with \n in BUFFER."
  (interactive "*b")
  (save-excursion
    (with-current-buffer buffer
      (goto-char (point-min))
      (while (search-forward (string ?\C-m ?\C-j) nil t)
        (replace-match (string ?\C-j) nil t)))))

(defun expand-file-name-exists-p (&rest args)
  "Return `expand-file-name' ARGS if it exists, or nil."
  (let ((file (apply #'expand-file-name args)))
    (if (file-exists-p file)
        file
      nil)))

(defun kill-region-or-backward-word (arg)
  "If region is active, kill; otherwise kill word backward with ARG."
  (interactive "p")
  (if (region-active-p)
      (kill-region (region-beginning) (region-end))
    (if (bound-and-true-p paredit-mode)
        (paredit-backward-kill-word)
      (backward-kill-word arg))))

(defun unfill-buffer (&optional buffer-or-name)
  "Unfill entire contents of BUFFER-OR-NAME."
  (with-current-buffer (or buffer-or-name (current-buffer))
    (save-excursion
      (save-restriction
        (unfill-region (point-min) (point-max))))))

(defun waterfall-list (car list rest)
  "Cons CAR with each element in LIST in a waterfall fashion, end with REST.
For use with the `with-eval-after-loads' function."
  (cond ((atom list) `(,car ',list ,@rest))
        ((= 1 (length list)) `(,car ',(car list) ,@rest))
        (t
         `(,car ',(car list)
                ,(waterfall-list car (cdr list) rest)))))


;;; Comment-or-uncomment-sexp
;; from https://endlessparentheses.com/a-comment-or-uncomment-sexp-command.html

(defun uncomment-sexp (&optional n)
  "Uncomment N sexps around point."
  (interactive "P")
  (let* ((initial-point (point-marker))
         (inhibit-field-text-motion t)
         (p)
         (end (save-excursion
                (when (elt (syntax-ppss) 4)
                  (re-search-backward comment-start-skip
                                      (line-beginning-position)
                                      t))
                (setq p (point-marker))
                (comment-forward (point-max))
                (point-marker)))
         (beg (save-excursion
                (forward-line 0)
                (while (and (not (bobp))
                            (= end (save-excursion
                                     (comment-forward (point-max))
                                     (point))))
                  (forward-line -1))
                (goto-char (line-end-position))
                (re-search-backward comment-start-skip
                                    (line-beginning-position)
                                    t)
                (ignore-errors
                  (while (looking-at-p comment-start-skip)
                    (forward-char -1)))
                (point-marker))))
    (unless (= beg end)
      (uncomment-region beg end)
      (goto-char p)
      ;; Indentify the "top-level" sexp inside the comment.
      (while (and (ignore-errors (backward-up-list) t)
                  (>= (point) beg))
        (skip-chars-backward (rx (syntax expression-prefix)))
        (setq p (point-marker)))
      ;; Re-comment everything before it.
      (ignore-errors
        (comment-region beg p))
      ;; And everything after it.
      (goto-char p)
      (forward-sexp (or n 1))
      (skip-chars-forward "\r\n[:blank:]")
      (if (< (point) end)
          (ignore-errors
            (comment-region (point) end))
        ;; If this is a closing delimiter, pull it up.
        (goto-char end)
        (skip-chars-forward "\r\n[:blank:]")
        (when (eq 5 (car (syntax-after (point))))
          (delete-indentation))))
    ;; Without a prefix, it's more useful to leave point where
    ;; it was.
    (unless n
      (goto-char initial-point))))

(defun comment-sexp--raw ()
  "Comment the sexp at point or ahead of point."
  (pcase (or (bounds-of-thing-at-point 'sexp)
             (save-excursion
               (skip-chars-forward "\r\n[:blank:]")
               (bounds-of-thing-at-point 'sexp)))
    (`(,l . ,r)
     (goto-char r)
     (skip-chars-forward "\r\n[:blank:]")
     (save-excursion
       (comment-region l r))
     (skip-chars-forward "\r\n[:blank:]"))))

(defun comment-or-uncomment-sexp (&optional n)
  "Comment the sexp at point and move past it.
If already inside (or before) a comment, uncomment instead.
With a prefix argument N, (un)comment that many sexps."
  (interactive "P")
  (if (or (elt (syntax-ppss) 4)
          (< (save-excursion
               (skip-chars-forward "\r\n[:blank:]")
               (point))
             (save-excursion
               (comment-forward 1)
               (point))))
      (uncomment-sexp n)
    (dotimes (_ (or n 1))
      (comment-sexp--raw))))


;;; Sort sexps
;; from https://github.com/alphapapa/unpackaged.el#sort-sexps
;; and https://github.com/alphapapa/unpackaged.el/issues/20

(defun sort-sexps (beg end &optional key-fn sort-fn)
  "Sort sexps between BEG and END.
Comments stay with the code below.

Optional argument KEY-FN will determine where in each sexp to
start sorting.  e.g. (lambda (sexp) (symbol-name (car sexp)))

Optional argument SORT-FN will determine how to sort two sexps'
strings.  It's passed to `sort'.  By default, it sorts the sexps
with `string<' starting with the key determined by KEY-FN."
  (interactive "r")
  (cl-flet ((skip-whitespace () (while (looking-at (rx (1+ (or space "\n"))))
                                  (goto-char (match-end 0))))
            (skip-both () (while (cond ((or (nth 4 (syntax-ppss))
                                            (ignore-errors
                                              (save-excursion
                                                (forward-char 1)
                                                (nth 4 (syntax-ppss)))))
                                        (forward-line 1))
                                       ((looking-at (rx (1+ (or space "\n"))))
                                        (goto-char (match-end 0)))))))
    (save-excursion
      (save-restriction
        (narrow-to-region beg end)
        (goto-char beg)
        (skip-both)
        (cl-destructuring-bind (sexps markers)
            (cl-loop do (skip-whitespace)
                     for start = (point-marker)
                     for sexp = (ignore-errors
                                  (read (current-buffer)))
                     for end = (point-marker)
                     while sexp
                     ;; Collect the real string, then one used for sorting.
                     collect (cons (buffer-substring (marker-position start)
                                                     (marker-position end))
                                   (save-excursion
                                     (goto-char (marker-position start))
                                     (skip-both)
                                     (if key-fn
                                         (funcall key-fn sexp)
                                       (buffer-substring
                                        (point)
                                        (marker-position end)))))
                     into sexps
                     collect (cons start end)
                     into markers
                     finally return (list sexps markers))
          (setq sexps (sort sexps (if sort-fn sort-fn
                                    (lambda (a b)
                                      (string< (cdr a) (cdr b))))))
          (cl-loop for (real . sort) in sexps
                   for (start . end) in markers
                   do (progn
                        (goto-char (marker-position start))
                        (insert-before-markers real)
                        (delete-region (point) (marker-position end)))))))))

(defun acdw/sort-setups ()
  "Sort `setup' forms in the current buffer.
Actually sorts all forms, but based on the logic of `setup'.
In short, DO NOT USE THIS FUNCTION!!!"
  (save-excursion
    (sort-sexps
     (point-min) (point-max)
     ;; Key function
     nil
     ;; Sort function
     (lambda (s1 s2)                  ; oh god, this is worse.
       (let* ((s1 (cdr s1)) (s2 (cdr s2)) ; for the strings themselves
              (require-regexp (rx bos (* nonl) ":require"))
              (straight-regexp (rx bos (* nonl) ":straight"))
              (s1-require (string-match require-regexp s1))
              (s2-require (string-match require-regexp s2))
              (s1-straight (string-match straight-regexp s1))
              (s2-straight (string-match straight-regexp s2)))
         (cond
          ;; Straight forms require some weirdness
          ((and s1-straight s2-straight)
           (let* ((r (rx ":straight" (? "-when") (* space) (? "(")))
                  (s1 (replace-regexp-in-string r "" s1))
                  (s2 (replace-regexp-in-string r "" s2)))
             (string< s1 s2)))
          ;; requires should go first
          ((and s1-require (not s2-require)) t)
          ((and (not s1-require) s2-require) nil)
          ;; straights should go last
          ((and s1-straight (not s2-straight)) nil)
          ((and (not s1-straight) s2-straight) t)
          ;; else, just sort em.
          (t (string< s1 s2))))))))


;;; Emacs configuration functions

(defun emacs-git-pull-config (&optional remote branch)
  "`git-pull' Emacs' configuration from REMOTE and BRANCH.
REMOTE defaults to 'origin', BRANCH to 'main'."
  (let ((remote (or remote "origin"))
        (branch (or branch "main")))
    (with-message (format "Pulling Emacs's configuration from %s" branch)
      (shell-command (concat "git -C "
                             "\"" (expand-file-name user-emacs-directory) "\""
                             " pull " remote " " branch)
                     (get-buffer-create "*emacs-git-pull-config-output*")
                     (get-buffer-create "*emacs-git-pull-config-error*")))))

(defun emacs-reload (&optional git-pull-first)
  "Reload Emacs's configuration files.
With a prefix argument GIT-PULL-FIRST, run git pull on the repo
first."
  (interactive "P")
  (when git-pull-first
    (emacs-git-pull-config))
  (let ((init-files (append
                     ;; Load lisp libraries first, in case their functionality
                     ;; is used by {early-,}init.el
                     (let* ((dir (expand-file-name "lisp/"
                                                   user-emacs-directory))
                            (full-name (lambda (f)
                                         (concat
                                          (file-name-as-directory dir) f))))
                       (mapcar full-name (directory-files dir nil "\\.el\\'")))
                     ;; Load regular init files
                     (list (locate-user-emacs-file "early-init.el")
                           (locate-user-emacs-file "init.el" ".emacs"))))
        (debug-on-error t))
    (with-message "Saving init files"
      (save-some-buffers :no-confirm (lambda () (member (buffer-file-name)
                                                        init-files))))
    (dolist (file init-files)
      (with-message (format "Loading %s" file)
        (when (file-exists-p file)
          (load-file file))))))


;;; Specialized functions

(defun acdw/copy-region-plain (beg end)
  "Copy a region from BEG to END to clipboard, removing all Org formatting."
  (interactive "r")
  (let ((s (buffer-substring-no-properties beg end))
        (extracted-heading (when (derived-mode-p 'org-mode)
                             (acdw/org-extract-heading-text))))
    (with-temp-buffer
      (insert s)
      (let ((sentence-end-double-space nil))
        ;; Remove org stuff
        (when extracted-heading         ; Replace org heading with plaintext
          (goto-char (point-min))
          (kill-line)
          (insert extracted-heading))
        ;; Delete property drawers
        (replace-regexp org-property-drawer-re "")
        ;; Delete logbook drawers
        (replace-regexp org-logbook-drawer-re "")
        ;; Replace list items with their contents, paragraphed
        (replace-regexp org-list-full-item-re "
\4")
        ;; Delete comment lines
        (replace-regexp (concat org-comment-regexp ".*$") "")
        ;; Re-fill text for clipboard
        (unfill-region (point-min) (point-max))
        (flush-lines "^$" (point-min) (point-max)))
      ;; Copy buffer
      (copy-region-as-kill (point-min) (point-max))))
  (when (called-interactively-p 'interactive)
    (indicate-copied-region))
  (setq deactivate-mark t)
  nil)

;; https://emacs.stackexchange.com/questions/36366/
(defun html-body-id-filter (output backend info)
  "Remove random ID attributes generated by Org."
  (when (eq backend 'html)
    (replace-regexp-in-string
     " id=\"[[:alpha:]-]*org[[:alnum:]]\\{7\\}\""
     ""
     output t)))

(defun html-body-div-filter (output backend info)
  "Remove wrapping divs generated by Org."
  (when (eq backend 'html)
    (replace-regexp-in-string
     "</?div[^>]*>\n*" ""
     output t)))

(defun org-demote-headings (backend)
  (while (/= (point) (point-max))
    (org-next-visible-heading 1)
    (org-demote-subtree)))

(defun acdw/org-export-copy-html ()
  "Copy a tree as HTML."
  (interactive)
  (require 'ox-html)
  (org-export-with-buffer-copy
   ;; (add-hook 'org-export-before-parsing-hook #'org-demote-headings nil t)
   (let ((extracted-heading (acdw/org-extract-heading-text))
         (org-export-show-temporary-export-buffer nil)
         (org-export-filter-final-output-functions
          '(html-body-id-filter html-body-div-filter))
         (org-export-with-smart-quotes nil)
         (org-export-smart-quotes-alist nil))
     (insert "* ORG IS STUPID SOMETIMES\n")
     (goto-char (point-min))
     (org-html-export-as-html nil t nil t)
     (with-current-buffer "*Org HTML Export*"
       (goto-char (point-min))
       (replace-regexp "<h2>.*</h2>" "")
       (insert "<h2>" extracted-heading "</h2>")
       (flush-lines "^$" (point-min) (point-max))
       (let ((sentence-end-double-space nil))
         (unfill-region (point-min) (point-max)))
       (replace-regexp "<h" "\n<h" nil (1+ (point-min)) (point-max))
       (replace-regexp "<p" "\n<p" nil (point-min) (point-max))
       (replace-regexp "<p> +" "<p>" nil (point-min) (point-max))
       (replace-regexp " +</p>" "</p>" nil (point-min) (point-max))
       (copy-region-as-kill (point-min) (point-max)))))
  (when (called-interactively-p 'interactive)
    (indicate-copied-region))
  (setq deactivate-mark t)
  nil)

(defun acdw/org-export-copy ()
  "copy a tree"
  (interactive)
  (require 'ox-ascii)
  (let ((extracted-heading (acdw/org-extract-heading-text)))
    ;; Export to ASCII - not async, subtree only, visible-only, body-only
    (let ((org-export-show-temporary-export-buffer nil))
      (org-ascii-export-as-ascii nil t nil t))
    (with-current-buffer "*Org ASCII Export*"
      (goto-char (point-min))
      (insert extracted-heading)
      (newline 2)

      (replace-regexp org-list-full-item-re "
\4")
      
      (let ((sentence-end-double-space nil))
        (unfill-region (point-min) (point-max)))
      (flush-lines "^$" (point-min) (point-max))
      
      (copy-region-as-kill (point-min) (point-max)))

    (when (called-interactively-p 'interactive)
      (indicate-copied-region))
    (setq deactivate-mark t)
    nil))

(defun acdw/org-extract-heading-text ()
  "Extract the heading text from an `org-mode' heading."
  (let ((heading (org-no-properties (org-get-heading t t t t))))
    (message
     (replace-regexp-in-string org-link-bracket-re
                               (lambda (match)
                                 (match-string-no-properties 2 match))
                               heading))))

(defun acdw/sync-dir (&optional file make-directory)
  "Return FILE from ~/Sync.
Optional argument MAKE-DIRECTORY makes the directory.
Logic is as in `acdw/dir', which see."
  (let ((dir (expand-file-name (convert-standard-filename "~/Sync/"))))
    (if file
        (let ((file-name (expand-file-name (convert-standard-filename file)
                                           dir)))
          (when make-directory
            (make-directory (file-name-directory file-name) 'parents))
          file-name)
      dir)))

(defun acdw/dir (&optional file make-directory)
  "Place Emacs files in one place.

If called without parameters, `acdw/dir' expands to
~/.emacs.d/var or similar.  If called with FILE, `acdw/dir'
expands FILE to ~/.emacs.d/var, optionally making its directory
if MAKE-DIRECTORY is non-nil."
  (let ((dir (expand-file-name (convert-standard-filename "var/")
                               user-emacs-directory)))
    (if file
        (let ((file-name (expand-file-name (convert-standard-filename file)
                                           dir)))
          (when make-directory
            (make-directory (file-name-directory file-name) 'parents))
          file-name)
      dir)))

(defun acdw/find-emacs-source () ;; doesn't work right now
  "Find where Emacs' source tree is."
  (acdw/system
   (:work (expand-file-name
           (concat "~/src/emacs-" emacs-version "/src")))
   (:home (expand-file-name "~/src/pkg/emacs/src/emacs-git/src"))
   (:other nil)))

(defun acdw/gc-disable ()
  "Functionally disable the Garbage collector."
  (setq gc-cons-threshold most-positive-fixnum
        gc-cons-percentage 0.8))

(defun acdw/gc-enable ()
  "Enable the Garbage collector."
  (setq gc-cons-threshold (* 800 1024 1024)
        gc-cons-percentage 0.1))

(defun acdw/insert-iso-date (arg)
  "Insert the ISO-8601-formatted date, optionally including time (pass ARG)."
  (interactive "P")
  (let ((format (if arg "%FT%T%z" "%F")))
    (insert (format-time-string format (current-time)))))

(defun acdw/kill-a-buffer (&optional prefix)
  "Kill this buffer, or other buffers, depending on PREFIX.

\\[acdw/kill-a-buffer] : Kill CURRENT buffer and window
\\[universal-argument] \\[acdw/kill-a-buffer] : Kill OTHER buffer and window
\\[universal-argument] \\[universal-argument] \\[acdw/kill-a-buffer] : Kill ALL OTHER buffers and windows

Prompt only if there are unsaved changes."
  (interactive "P")
  (pcase (or (car prefix) 0)
    (0  (kill-current-buffer)
        (unless (one-window-p) (delete-window)))
    (4  (other-window 1)
        (kill-current-buffer)
        (unless (one-window-p) (delete-window)))
    (16 (mapc 'kill-buffer (delq (current-buffer) (buffer-list)))
        (delete-other-windows))))

(defun acdw/sunrise-sunset (sunrise-command sunset-command)
  "Run SUNRISE-COMMAND at sunrise, and SUNSET-COMMAND at sunset."
  (let* ((times-regex (rx (* nonl)
                          (: (any ?s ?S) "unrise") " "
                          (group (repeat 1 2 digit) ":"
                                 (repeat 1 2 digit)
                                 (: (any ?a ?A ?p ?P) (any ?m ?M)))
                          (* nonl)
                          (: (any ?s ?S) "unset") " "
                          (group (repeat 1 2 digit) ":"
                                 (repeat 1 2 digit)
                                 (: (any ?a ?A ?p ?P) (any ?m ?M)))
                          (* nonl)))
         (ss (acdw/supress-messages #'sunrise-sunset))
         (_m (string-match times-regex ss))
         (sunrise-time (match-string 1 ss))
         (sunset-time (match-string 2 ss)))
    (run-at-time sunrise-time (* 60 60 24) sunrise-command)
    (run-at-time sunset-time (* 60 60 24) sunset-command)
    (run-at-time "12:00am" (* 60 60 24) sunset-command)))

(defun acdw/supress-messages (oldfn &rest args) ; from pkal
  "Advice wrapper for suppressing `message'.
OLDFN is the wrapped function, that is passed the arguments
ARGS."
  (let ((msg (current-message)))
    (prog1
        (let ((inhibit-message t))
          (apply oldfn args))
      (when msg
        (message "%s" msg)))))

(defun acdw/setup-fringes ()
  "Set up fringes how I likes 'em."
  (define-fringe-bitmap 'left-curly-arrow
    [#b01100000
     #b00110000
     #b00011000
     #b00001100]
    4 8 'center)
  (define-fringe-bitmap 'right-curly-arrow
    [#b00000011
     #b00000110
     #b00001100
     #b00011000]
    4 8 'center)
  (define-fringe-bitmap 'left-arrow
    [#b01100000
     #b01010000]
    2 8 '(top t))
  (define-fringe-bitmap 'right-arrow
    [#b00000011
     #b00000101]
    2 8 '(top t))
  (setq-local indicate-empty-lines nil
              indicate-buffer-boundaries '((top . right)
                                           (bottom . right)))
  (custom-set-faces '(fringe
                      ((t (:foreground "dim gray"))))))

(defun acdw/require-private ()
  "Load \"~/.emacs.d/private.el\".
It's called 'require-private' for historical reasons."
  (load (expand-file-name "private.el" user-emacs-directory)
        :noerror :nomessage))


;;; Recentf renaming with dired
;; from ... somewhere.  'rjs', apparently?
;; I'm throwing these here because they look better here than in init.el.
;; Comments are "rjs"'s.

;; Magic advice to rename entries in recentf when moving files in
;; dired.
(defun rjs/recentf-rename-notify (oldname newname &rest _args)
  "Magically rename files from OLDNAME to NEWNAME when moved in `dired'."
  (if (file-directory-p newname)
      (rjs/recentf-rename-directory oldname newname)
    (rjs/recentf-rename-file oldname newname)))

(defun rjs/recentf-rename-file (oldname newname)
  "Rename a file from OLDNAME to NEWNAME in `recentf-list'."
  (setq recentf-list
        (mapcar (lambda (name)
                  (if (string-equal name oldname)
                      newname
                    oldname))
                recentf-list)))

(defun rjs/recentf-rename-directory (oldname newname)
  "Rename directory from OLDNAME to NEWNAME in `recentf-list'."
  ;; oldname, newname and all entries of recentf-list should already
  ;; be absolute and normalised so I think this can just test whether
  ;; oldname is a prefix of the element.
  (setq recentf-list
        (mapcar (lambda (name)
                  (if (string-prefix-p oldname name)
                      (concat newname (substring name (length oldname)))
                    name))
                recentf-list)))


;;; Sort setq...
;; https://emacs.stackexchange.com/questions/33039/

(defun sort-setq ()
  "Sort a setq.  Must be a defun."
  (interactive)
  (save-excursion
    (save-restriction
      (let ((sort-end (progn (end-of-defun)
                             (backward-char)
                             (point-marker)))
            (sort-beg (progn (beginning-of-defun)
                             (re-search-forward "[ \\t]*(" (point-at-eol))
                             (forward-sexp)
                             (re-search-forward "\\_<" (point-at-eol))
                             (point-marker))))
        (narrow-to-region (1- sort-beg) (1+ sort-end))
        (sort-subr nil #'sort-setq-next-record #'sort-setq-end-record)))))

(defun sort-setq-next-record ()
  "Sort the next record of a `setq' form."
  (condition-case nil
      (progn
        (forward-sexp 1)
        (backward-sexp))
    ('scan-error (goto-char (point-max)))))

(defun sort-setq-end-record ()
  "Sort the end of a `setq' record."
  (condition-case nil
      (forward-sexp 2)
    ('scan-error (goto-char (point-max)))))


;;; Crux tweaks

;; `crux-other-window-or-switch-buffer' doesn't take an argument.
(defun acdw/other-window-or-switch-buffer (&optional arg)
  "Call `other-window' with ARG or switch buffers, depending on window count."
  (interactive "P")
  (if (one-window-p)
      (switch-to-buffer nil)
    (other-window (or arg 1))))

(defun acdw/other-window-or-switch-buffer-backward ()
  "Do `acdw/other-window-or-switch-buffer', but backward."
  (interactive)
  (acdw/other-window-or-switch-buffer -1))


;;; Auth-sources
;; https://github.com/emacs-circe/circe/wiki/Configuration
(defun acdw/fetch-password (&rest params)
  "Fetch a password from `auth-source' using PARAMS.
This function is internal.  Use `acdw/make-password-fetcher' instead."
  (let ((match (car (apply #'auth-source-search params))))
    (if match
        (let ((secret (plist-get match :secret)))
          (if (functionp secret)
              (funcall secret)
            secret))
      (message "Password not found for %S" params))))

(defun acdw/make-password-fetcher (&rest params)
  "Make a function that will call `acdw/fetch-password' with PARAMS."
  (lambda (&rest _)
    (apply #'acdw/fetch-password params)))


;;; Paren annoyances
(defun acdw/stop-paren-annoyances (&optional buffer)
  "Locally turn off paren-checking functions in BUFFER."
  (with-current-buffer (or buffer (current-buffer))
    (setq-local blink-matching-paren nil
                show-paren-mode nil)))


;;; 💩
(defun 💩 (&optional n)
  "💩 x N."
  (interactive "p")
  (let ((n (or n 1)))
    (while (> n 0)
      (insert "💩")
      (setq n (1- n)))))

(defun spongebob-case-region (beg end)
  "Make region, defined by BEG and END, lOoK lIkE tHiS."
  (interactive "*r")
  (save-excursion
    (let (case)
      (goto-char beg)
      (while (< (point) end)
        (if (looking-at "[[:alpha:]]")
            (if (setq case (not case))
                (upcase-region (point) (progn (forward-char 1) (point)))
              (downcase-region (point) (progn (forward-char 1) (point))))
          (forward-char 1))))))

(defun spongebob-case-word (n)
  "Spongebob-case N words forward, beginning at point, moving over."
  (interactive "*p")
  (spongebob-case-region (point) (progn (forward-word n) (point))))

(defun spongebob-case-dwim (arg)
  "Spongebob-case words in the region if active, else word at point.
If ARG exists, it's passed to `spongebob-case-word'."
  (interactive "*p")
  (if (use-region-p)
      (spongebob-case-region (region-beginning) (region-end))
    (spongebob-case-word arg)))


;;; Fat finger solutions
(defun acdw/fat-finger-exit (&optional prefix)
  "Delete a frame, or kill Emacs with confirmation.
When called with PREFIX, just kill Emacs without confirmation."
  (interactive "P")
  (if (or prefix
          (and (= 1 (length (frame-list)))
               (yes-or-no-p "This is the last frame!  Wanna quit?")))
      (kill-emacs)
    (ignore-errors
      (delete-frame))))

(defun acdw/disabled-command-function (&optional cmd keys)
  (let ((cmd (or cmd this-command))
        (keys (or keys (this-command-keys))))
    ;; this logic stolen from original `disabled-command-function'
    (if (or (eq (aref keys 0) (if (stringp keys)
                                  (aref "\M-x" 0)
                                ?\M-x))
            (and (>= (length keys) 2)
                 (eq (aref keys 0) meta-prefix-char)
                 (eq (aref keys 1) ?x)))
        ;; it's been run as an M-x command, we want to do it
        (call-interactively cmd)
      ;; else, tell the user it's disabled.
      (message (substitute-command-keys
                (concat "Command `%s' has been disabled.  "
                        "Run with \\[execute-extended-command]."))
               cmd))))


;;; cribbed

;; https://jao.io/blog/2021-09-08-high-signal-to-noise-emacs-command.html
(defun jao-buffer-same-mode (&rest modes)
  "Pop to a buffer with a mode among MODES, or the current one if not given."
  (interactive)
  (let* ((modes (or modes (list major-mode)))
         (pred (lambda (b)
                 (let ((b (get-buffer (if (consp b) (car b) b))))
                   (member (buffer-local-value 'major-mode b) modes)))))
    (pop-to-buffer (read-buffer "Buffer: " nil t pred))))

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