emacs/lisp/acdw.el

713 lines
26 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.el --- miscellaneous -*- lexical-binding: t; coding: utf-8-unix -*-
;; Author: Case Duckworth <acdw@acdw.net>
;; 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 (files &rest body)
"Execute BODY after FILES are loaded.
This macro simplifies `with-eval-after-load' for multiple nested
features."
(declare (indent 1) (debug (form def-body)))
(waterfall-list 'with-eval-after-load files 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)))))))))
;;; 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)
(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 t t))
(with-current-buffer "*Org ASCII Export*"
(goto-char (point-min))
(insert extracted-heading)
(newline)
(newline)
(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/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)))))
;;; 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))))
;;; 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