532 lines
20 KiB
EmacsLisp
532 lines
20 KiB
EmacsLisp
;;; acdw.el --- various meta-whatevers -*- lexical-binding: t -*-
|
||
|
||
;;; Commentary:
|
||
|
||
;; What's that saying about how the hardest things in computer science
|
||
;; are naming and off-by-one errors? Well, the naming one I know very
|
||
;; well. I've been trying to figure out a good way to prefix my
|
||
;; bespoke functions, other stuff I found online, and various emacs
|
||
;; lisp detritus for quite some time (I reckon at over a year, as of
|
||
;; 2021-11-02). Finally, I found the answer in the writings of Daniel
|
||
;; Mendler: I'll prefix everything with a `+' !
|
||
|
||
;; To that end, pretty much everything in lisp/ will have a filename
|
||
;; like "+org.el", except of course this file, and maybe a few
|
||
;; /actually original/ libraries I haven't had the wherewithal to
|
||
;; package out properly yet.
|
||
|
||
;; Is it perfect? No. Is it fine? Yes. Here it is.
|
||
|
||
;;; Code:
|
||
|
||
(require 'diary-lib)
|
||
(require 'solar) ; for +sunrise-sunset
|
||
|
||
;;; Define a directory and an expanding function
|
||
|
||
(defmacro +define-dir (name directory &optional docstring inhibit-mkdir)
|
||
"Define a variable and function NAME expanding to DIRECTORY.
|
||
DOCSTRING is applied to the variable. Ensure DIRECTORY exists in
|
||
the filesystem, unless INHIBIT-MKDIR is non-nil."
|
||
(declare (indent 2)
|
||
(doc-string 3))
|
||
(unless inhibit-mkdir
|
||
(make-directory (eval directory) :parents))
|
||
`(progn
|
||
(defvar ,name ,directory
|
||
,(concat docstring (when docstring "\n")
|
||
"Defined by `/define-dir'."))
|
||
(defun ,name (file &optional mkdir)
|
||
,(concat "Expand FILE relative to variable `" (symbol-name name) "'.\n"
|
||
"If MKDIR is non-nil, the directory is created.\n"
|
||
"Defined by `/define-dir'.")
|
||
(let ((file-name (expand-file-name (convert-standard-filename file)
|
||
,name)))
|
||
(when mkdir
|
||
(make-directory (file-name-directory file-name) :parents))
|
||
file-name))))
|
||
|
||
(defun +suppress-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 +ensure-after-init (function)
|
||
"Ensure FUNCTION runs after init, or now if already initialized.
|
||
If Emacs is already started, run FUNCTION. Otherwise, add it to
|
||
`after-init-hook'. FUNCTION is called with no arguments."
|
||
(if after-init-time
|
||
(funcall function)
|
||
(add-hook 'after-init-hook function)))
|
||
|
||
(defmacro +with-ensure-after-init (&rest body)
|
||
"Ensure BODY forms run after init.
|
||
Convenience macro wrapper around `+ensure-after-init'."
|
||
(declare (indent 0) (debug (def-body)))
|
||
`(+ensure-after-init (lambda () ,@body)))
|
||
|
||
(defun +remember-prefix-arg (p-arg P-arg)
|
||
"Display prefix ARG, in \"p\" and \"P\" `interactive' types.
|
||
I keep forgetting how they differ."
|
||
(interactive "p\nP")
|
||
(message "p: %S P: %S" p-arg P-arg))
|
||
|
||
(defmacro +defvar (var value &rest _)
|
||
"Quick way to `setq' a variable from a `defvar' form."
|
||
(declare (doc-string 3) (indent 2))
|
||
`(setq ,var ,value))
|
||
|
||
(defmacro +with-message (message &rest body)
|
||
"Execute BODY, with MESSAGE.
|
||
If body executes without errors, MESSAGE...Done will be displayed."
|
||
(declare (indent 1))
|
||
(let ((msg (gensym)))
|
||
`(let ((,msg ,message))
|
||
(condition-case e
|
||
(progn (message "%s..." ,msg)
|
||
,@body)
|
||
(:success (message "%s...done" ,msg))
|
||
(t (signal (car e) (cdr e)))))))
|
||
|
||
(defun +mapc-some-buffers (func &optional predicate)
|
||
"Perform FUNC on all buffers satisfied by PREDICATE.
|
||
By default, act on all buffers.
|
||
|
||
Both PREDICATE and FUNC are called with no arguments, but within
|
||
a `with-current-buffer' form on the currently-active buffer.
|
||
|
||
As a special case, if PREDICATE is a list, it will be interpreted
|
||
as a list of major modes. In this case, FUNC will only be called
|
||
on buffers derived from one of the modes in PREDICATE."
|
||
(let ((pred (or predicate t)))
|
||
(dolist (buf (buffer-list))
|
||
(with-current-buffer buf
|
||
(when (cond ((functionp pred)
|
||
(funcall pred))
|
||
((listp pred)
|
||
(apply #'derived-mode-p pred))
|
||
(t pred))
|
||
(funcall func))))))
|
||
|
||
;; https://github.com/cstby/emacs.d/blob/main/init.el#L67
|
||
(defun +clean-empty-lines (&optional begin end)
|
||
"Remove duplicate empty lines from BEGIN to END.
|
||
Called interactively, this function acts on the region, if
|
||
active, or else the entire buffer."
|
||
(interactive "*r")
|
||
(unless (region-active-p)
|
||
(setq begin (point-min)
|
||
end (save-excursion
|
||
(goto-char (point-max))
|
||
(skip-chars-backward "\n[:space:]")
|
||
(point))))
|
||
(save-excursion
|
||
(save-restriction
|
||
(narrow-to-region begin end)
|
||
(goto-char (point-min))
|
||
(while (re-search-forward "\n\n\n+" nil :move)
|
||
(replace-match "\n\n"))
|
||
;; Insert a newline at the end.
|
||
(goto-char (point-max))
|
||
(unless (or (buffer-narrowed-p)
|
||
(= (line-beginning-position) (line-end-position)))
|
||
(insert "\n")))))
|
||
|
||
(defcustom +open-paragraph-ignore-modes '(special-mode lui-mode comint-mode)
|
||
"Modes in which `+open-paragraph' makes no sense."
|
||
:type '(repeat function))
|
||
|
||
(defun +open-paragraph (&optional arg)
|
||
"Open a paragraph after paragraph at point.
|
||
A paragraph is defined as continguous non-empty lines of text
|
||
surrounded by empty lines, so opening a paragraph means to make
|
||
three blank lines, then place the point on the second one.
|
||
|
||
Called with prefix ARG, open a paragraph before point."
|
||
;; TODO: Take an integer as ARG, allowing for skipping paragraphs up and down.
|
||
(interactive "*P")
|
||
;; TODO: add `+open-paragraph-ignore-modes'
|
||
(unless (apply #'derived-mode-p +open-paragraph-ignore-modes)
|
||
;; Go to next blank line. This /isn't/ `end-of-paragraph-text' because
|
||
;; that's weird with org, and I'm guessing other modes too.
|
||
(unless (looking-at "^$") (forward-line (if arg -1 +1)))
|
||
(while (and (not (looking-at "^$"))
|
||
(= 0 (forward-line (if arg -1 +1)))))
|
||
(newline)
|
||
(when arg (newline) (forward-line -2))
|
||
(delete-blank-lines)
|
||
(newline 2)
|
||
(previous-line)))
|
||
|
||
(defun +split-window-then (&optional where arg)
|
||
"Split the window into a new buffer.
|
||
With non-nil ARG (\\[universal-argument] interactively), don't
|
||
prompt for a buffer to switch to. This function will split the
|
||
window using `split-window-sensibly', or open the new window in
|
||
the direction specified by WHERE. WHERE is ignored when called
|
||
interactively; if you want specific splitting, use
|
||
`+split-window-right-then' or `+split-window-below-then'."
|
||
(interactive "i\nP")
|
||
;; TODO: Canceling at the switching phase leaves the point in the other
|
||
;; window. Ideally, the user would see this as one action, meaning a cancel
|
||
;; would return to the original window.
|
||
(pcase where
|
||
;; These directions are 'backward' to the OG Emacs split-window commands,
|
||
;; because by default Emacs leaves the cursor in the original window. Most
|
||
;; users probably expect a switch to the new window, at least I do.
|
||
((or 'right :right) (split-window-right) (other-window 1))
|
||
((or 'left :left) (split-window-right))
|
||
((or 'below :below) (split-window-below) (other-window 1))
|
||
((or 'above :above) (split-window-below))
|
||
((pred null)
|
||
(or (split-window-sensibly)
|
||
(if (< (window-height) (window-width))
|
||
(split-window-below)
|
||
(split-window-right)))
|
||
(other-window 1))
|
||
(_ (user-error "Unknown WHERE paramater: %s" where)))
|
||
(unless arg
|
||
(condition-case nil
|
||
(call-interactively
|
||
(pcase (read-char "(B)uffer or (F)ile?")
|
||
(?b (if (fboundp #'consult-buffer)
|
||
#'consult-buffer
|
||
#'switch-to-buffer))
|
||
(?f #'find-file)
|
||
(_ #'ignore)))
|
||
(quit (delete-window)))))
|
||
|
||
(defun +split-window-right-then (&optional arg)
|
||
"Split window right, then prompt for a new buffer.
|
||
With optional ARG (\\[universal-argument]), just split."
|
||
(interactive "P")
|
||
(+split-window-then :right arg))
|
||
|
||
(defun +split-window-below-then (&optional arg)
|
||
"Split window below, then prompt for a new buffer.
|
||
With optional ARG (\\[universal-argument]), just split."
|
||
(interactive "P")
|
||
(+split-window-then :below arg))
|
||
|
||
(defun +bytes (number unit)
|
||
"Convert NUMBER UNITs to bytes.
|
||
UNIT can be one of :kb, :mb, :gb, :tb, :pb, :eb, :zb, :yb; :kib, :mib, :gib,
|
||
:tib, :pib, :eib, :zib, :yib."
|
||
(* number (pcase unit
|
||
;; Base 10 units
|
||
(:kb 1000)
|
||
(:mb (* 1000 1000))
|
||
(:gb (* 1000 1000 1000))
|
||
(:tb (* 1000 1000 1000 1000))
|
||
(:pb (* 1000 1000 1000 1000 1000))
|
||
(:eb (* 1000 1000 1000 1000 1000 1000))
|
||
(:zb (* 1000 1000 1000 1000 1000 1000 1000))
|
||
(:yb (* 1000 1000 1000 1000 1000 1000 1000 1000))
|
||
;; Base 2 units
|
||
(:kib 1024)
|
||
(:mib (* 1024 1024))
|
||
(:gib (* 1024 1024 1024))
|
||
(:tib (* 1024 1024 1024 1024))
|
||
(:pib (* 1024 1024 1024 1024 1024))
|
||
(:eib (* 1024 1024 1024 1024 1024 1024))
|
||
(:zib (* 1024 1024 1024 1024 1024 1024 1024))
|
||
(:yib (* 1024 1024 1024 1024 1024 1024 1024 1024)))))
|
||
|
||
;;; Font lock TODO keywords
|
||
|
||
(defcustom font-lock-todo-keywords '("TODO" "XXX" "FIXME" "BUG")
|
||
"Keywords to highlight with `font-lock-todo-face'.")
|
||
|
||
(defface font-lock-todo-face '((t :inherit font-lock-comment-face
|
||
:background "yellow"))
|
||
;; TODO: XXX: FIXME: BUG: testing :)
|
||
"Face for TODO keywords.")
|
||
|
||
(defun font-lock-todo-insinuate ()
|
||
(let ((keyword-regexp
|
||
(rx bow (group (eval (let ((lst '(or)))
|
||
(dolist (kw font-lock-todo-keywords)
|
||
(push kw lst))
|
||
(nreverse lst))))
|
||
":")))
|
||
(font-lock-add-keywords
|
||
nil
|
||
`((,keyword-regexp 1 'font-lock-todo-face prepend)))))
|
||
|
||
;; I don't use this much but I always forget the exact implementation, so this
|
||
;; is more to remember than anything else.
|
||
(defmacro setc (&rest vars-and-vals)
|
||
"Set VARS-AND-VALS by customizing them or using set-default.
|
||
Use like `setq'."
|
||
`(progn ,@(cl-loop for (var val) on vars-and-vals by #'cddr
|
||
if (null val) return (user-error "Not enough arguments")
|
||
collecting `(funcall (or (get ',var 'custom-get)
|
||
#'set-default)
|
||
',var ',val)
|
||
into ret
|
||
finally return ret)))
|
||
|
||
(defun +set-faces (specs)
|
||
"Set fonts to SPECS.
|
||
Specs is an alist: its cars are faces and its cdrs are the plist
|
||
passed to `set-face-attribute'. Note that the FRAME argument is
|
||
always nil; this function is mostly intended for use in init."
|
||
(dolist (spec specs)
|
||
(apply #'set-face-attribute (car spec) nil (cdr spec))))
|
||
|
||
(defcustom chat-functions '(+irc
|
||
jabber-connect-all
|
||
;; slack-start
|
||
)
|
||
"Functions to start when calling `chat'."
|
||
:type '(repeat function)
|
||
:group 'applications)
|
||
|
||
(defun +string-repeat (n str)
|
||
"Repeat STR N times."
|
||
(let ((r ""))
|
||
(dotimes (_ n)
|
||
(setq r (concat r str)))
|
||
r))
|
||
|
||
(defun chat-disconnect ()
|
||
"Disconnect from all chats."
|
||
(interactive)
|
||
(+with-progress "Quitting circe..."
|
||
(ignore-errors
|
||
(circe-command-GQUIT "peace love bread")
|
||
(cancel-timer (irc-connection-get conn :flood-timer))))
|
||
(+with-progress "Quitting jabber..."
|
||
(ignore-errors
|
||
(jabber-disconnect)))
|
||
(when (boundp '+slack-teams)
|
||
(+with-progress "Quitting-slack..."
|
||
(dolist (team +slack-teams)
|
||
(ignore-errors
|
||
(slack-team-disconnect team)))
|
||
(ignore-errors (slack-ws-close))))
|
||
(+with-progress "Killing buffers..."
|
||
(ignore-errors
|
||
(+mapc-some-buffers (lambda () "Remove the buffer from tracking and kill it unconditionally."
|
||
(let ((kill-buffer-query-functions nil))
|
||
(tracking-remove-buffer (current-buffer))
|
||
(kill-buffer)))
|
||
(lambda () "Return t if derived from the following modes."
|
||
(derived-mode-p 'lui-mode
|
||
'jabber-chat-mode
|
||
'jabber-roster-mode
|
||
'jabber-browse-mode
|
||
'slack-mode))))))
|
||
|
||
;; I can never remember all the damn chat things I run, so this just does all of em.
|
||
(defun chat (&optional arg)
|
||
"Initiate all chat functions.
|
||
With optional ARG, kill all chat-related buffers first."
|
||
(interactive "P")
|
||
(when arg (chat-disconnect))
|
||
(dolist-with-progress-reporter (fn chat-functions)
|
||
"Connecting to chat..."
|
||
(call-interactively fn)))
|
||
|
||
(defun +forward-paragraph (arg)
|
||
"Move forward ARG (simple) paragraphs.
|
||
A paragraph here is simply defined: it's a block of buffer that's
|
||
separated from others by two newlines."
|
||
(interactive "p")
|
||
(let ((direction (/ arg (abs arg))))
|
||
(forward-line direction)
|
||
(while (not (or (bobp)
|
||
(eobp)
|
||
(= arg 0)))
|
||
(if (looking-at "^[ \f\t]*$")
|
||
(setq arg (- arg direction))
|
||
(forward-line direction)))))
|
||
|
||
(defun +backward-paragraph (arg)
|
||
"Move backward ARG (simple) paragraphs.
|
||
See `+forward-paragraph' for the behavior."
|
||
(interactive "p")
|
||
(+forward-paragraph (- arg)))
|
||
|
||
(defun +concat (&rest strings)
|
||
"Concat STRINGS separated by SEPARATOR.
|
||
Each item in STRINGS is either a string or a list or strings,
|
||
which is concatenated without any separator.
|
||
|
||
SEPARATOR defaults to the newline (\\n)."
|
||
(let (ret
|
||
;; I don't know why a `cl-defun' with
|
||
;; (&rest strings &key (separator "\n")) doesn't work
|
||
(separator (or (cl-loop for i from 0 upto (length strings)
|
||
if (eq (nth i strings) :separator)
|
||
return (nth (1+ i) strings))
|
||
"\n")))
|
||
(while strings
|
||
(let ((string (pop strings)))
|
||
(cond ((eq string :separator) (pop strings))
|
||
((listp string) (push (apply #'concat string) ret))
|
||
((stringp string) (push string ret)))))
|
||
(mapconcat #'identity (nreverse ret) separator)))
|
||
|
||
(defun +file-string (file)
|
||
"Fetch the contents of FILE and return its string."
|
||
(with-current-buffer (find-file-noselect file)
|
||
(buffer-string)))
|
||
|
||
(defmacro +with-progress (pr-args &rest body)
|
||
"Perform BODY wrapped in a progress reporter.
|
||
PR-ARGS is the list of arguments to pass to
|
||
`make-progress-reporter'; it can be a single string for the
|
||
message, as well. If you want to use a formatted string, wrap
|
||
the `format' call in a list."
|
||
(declare (indent 1))
|
||
(let ((reporter (gensym))
|
||
(pr-args (if (listp pr-args) pr-args (list pr-args))))
|
||
`(let ((,reporter (make-progress-reporter ,@pr-args)))
|
||
(prog1 (progn ,@body)
|
||
(progress-reporter-done ,reporter)))))
|
||
|
||
(defmacro +with-eval-after-loads (features &rest body)
|
||
"Execute BODY after all FEATURES are loaded."
|
||
(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)))))
|
||
|
||
(defun +scratch-buffer (&optional nomode)
|
||
"Create a new scratch buffer and switch to it.
|
||
If the region is active, paste its contents into the scratch
|
||
buffer. The scratch buffer inherits the mode of the current
|
||
buffer unless NOMODE is non-nil. When called interactively,
|
||
NOMODE will be set when called with \\[universal-argument]."
|
||
(interactive "P")
|
||
(let* ((mode major-mode)
|
||
(bufname (generate-new-buffer-name (format "*scratch (%s)*" mode)))
|
||
(paste (and (region-active-p)
|
||
(prog1
|
||
(buffer-substring (mark t) (point))
|
||
(deactivate-mark)))))
|
||
(when (and (not nomode)
|
||
(bound-and-true-p ess-dialect)) ; Not sure what `ess-dialect' is
|
||
(setq mode (intern-soft (concat ess-dialect "-mode"))))
|
||
;; Set up buffer
|
||
(switch-to-buffer (get-buffer-create bufname))
|
||
(when (and (not nomode) mode)
|
||
(ignore-errors (funcall mode)))
|
||
(insert (format "%s Scratch buffer for %s%s\n\n"
|
||
comment-start mode comment-end))
|
||
(when paste (insert paste))
|
||
(get-buffer bufname)))
|
||
|
||
(defun +indent-rigidly (arg &optional interactive)
|
||
"Indent all lines in the region, or the current line.
|
||
This calls `indent-rigidly' and passes ARG to it."
|
||
(interactive "P\np")
|
||
(unless (region-active-p)
|
||
(push-mark)
|
||
(push-mark (line-beginning-position) nil t)
|
||
(goto-char (line-end-position)))
|
||
(call-interactively #'indent-rigidly))
|
||
|
||
(defun +sort-lines (reverse beg end)
|
||
"Sort lines in region, ignoring leading whitespace.
|
||
REVERSE non-nil means descending order; interactively, REVERSE is
|
||
the prefix argument, and BEG and END are the region. The
|
||
variable `sort-fold-case' determines whether case affects the
|
||
sort order."
|
||
(interactive "P\nr")
|
||
(save-excursion
|
||
(save-restriction
|
||
(narrow-to-region beg end)
|
||
(goto-char (point-min))
|
||
(let ((inhibit-field-text-motion t))
|
||
(sort-subr reverse
|
||
#'forward-line
|
||
#'end-of-line
|
||
#'beginning-of-line-text)))))
|
||
|
||
(defun +crm-indicator (args)
|
||
"AROUND advice for `completing-read-multiple'."
|
||
;; [[https://github.com/minad/vertico/blob/8ab2cddf3a1fb8799611b1d35118bf579aaf3154/README.org][from vertico's README]]
|
||
(cons (format "[CRM%s] %s"
|
||
(replace-regexp-in-string
|
||
"\\`\\[.*?]\\*\\|\\[.*?]\\*\\'" ""
|
||
crm-separator)
|
||
(car args))
|
||
(cdr args)))
|
||
|
||
|
||
;;; Timers!
|
||
;; inspired by [[https://git.sr.ht/~protesilaos/tmr/tree/main/item/tmr.el][prot's tmr.el package]]
|
||
|
||
(defvar +timer-string nil)
|
||
(defvar +timer-timer nil)
|
||
|
||
(defcustom +timer-running-string "⏰"
|
||
"What to display when the timer is running."
|
||
:type 'string)
|
||
(defcustom +timer-done-string "❗"
|
||
"What to display when the timer is done."
|
||
:type 'string)
|
||
|
||
(defun +timer (time)
|
||
"Set a timer for TIME."
|
||
(interactive (list (read-string "Set a timer for how long? ")))
|
||
(let ((secs (cond ((natnump time) (* time 60))
|
||
((and (stringp time)
|
||
(string-match-p "[0-9]\\'" time))
|
||
(* (string-to-number time) 60))
|
||
(t (let ((secs 0)
|
||
(time time))
|
||
(save-match-data
|
||
(while (string-match "\\([0-9.]+\\)\\([hms]\\)" time)
|
||
(cl-incf secs
|
||
(* (string-to-number (match-string 1 time))
|
||
(pcase (match-string 2 time)
|
||
("h" 3600)
|
||
("m" 60)
|
||
("s" 1))))
|
||
(setq time (substring time (match-end 0)))))
|
||
secs)))))
|
||
(message "Setting timer for \"%s\" (%S seconds)..." time secs)
|
||
(setq +timer-string +timer-running-string)
|
||
(setq +timer-timer (run-with-timer secs nil
|
||
(lambda ()
|
||
(message "%S-second timer DONE!" secs)
|
||
(setq +timer-string +timer-done-string)
|
||
(let ((visible-bell t)
|
||
(ring-bell-function nil))
|
||
(ding))
|
||
(ding))))))
|
||
|
||
(defun +timer-cancel ()
|
||
"Cancel the running timer."
|
||
(interactive)
|
||
(cond ((not +timer-timer)
|
||
(message "No timer found!"))
|
||
(t
|
||
(cancel-timer +timer-timer)
|
||
(message "Timer canceled.")))
|
||
(setq +timer-string nil))
|
||
|
||
|
||
|
||
(defun +switch-to-last-buffer ()
|
||
"Switch to the last-used buffer in this window."
|
||
(interactive)
|
||
(switch-to-buffer nil))
|
||
|
||
(provide 'acdw)
|
||
;;; acdw.el ends here
|