1 files changed, 90 insertions, 505 deletions

@@ -1,28 +1,10 @@
-;;; 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:
+;;; acdw.el -- bits and bobs  -*- lexical-binding: t; -*-
+;; by C. Duckworth <acdw@acdw.net>
+(provide 'acdw)
 
-(require 'diary-lib)
-(require 'solar)                        ; for +sunrise-sunset
+(require 'cl-lib)
 
-;;; Define a directory and an expanding function
+;;; Define both a directory and a function expanding to a file in that directory
 
 (defmacro +define-dir (name directory &optional docstring inhibit-mkdir)
   "Define a variable and function NAME expanding to DIRECTORY.
@@ -46,488 +28,91 @@ the filesystem, unless INHIBIT-MKDIR is non-nil."
            (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)))))
+;;; Convenience macros
 
-(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."
+(defun eval-after-init (fn)
+  "Evaluate FN after inititation, or now if Emacs is initialized.
+FN 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-or-modes)
-  "Perform FUNC on all buffers satisfied by PREDICATE-OR-MODES.
-By default, act on all buffers.
-
-Both PREDICATE-OR-MODES 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-OR-MODES 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-OR-MODES."
-  (let ((pred (or predicate-or-modes 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."
+      (funcall fn)
+    (add-hook 'after-init-hook fn)))
+
+(defmacro eval-after (features &rest body)
+  "Evaluate BODY, but only after loading FEATURES.
+FEATURES can be an atom or a list; as an atom it works like
+`with-eval-after-load'.  The special feature `init' will evaluate
+BODY after Emacs is finished initializing."
+  (declare (indent 1)
+           (debug (form def-body)))
+   (if (eq features 'init)
+       `(eval-after-init (lambda () ,@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
+            (eval-after ,rest ,@body))))))
+
+;;; Convenience functions
+
+(defun define-keys (maps &rest keydefs)
+  "Define KEYDEFS in MAPS.
+Convenience wrapper around `define-key'."
+  (unless (zerop (mod (length keydefs) 2))
+    (user-error "Wrong number of arguments: %S" (length keydefs)))
+  (dolist (map (if (or (atom maps) (eq (car maps) 'keymap))
+                   (list maps)
+                 maps))
+    (cl-loop for (key def) on keydefs by #'cddr
+             do (let ((key (if (stringp key) (kbd key) key)))
+                  (define-key (if (symbolp map)
+                                  (symbol-value map)
+                                map)
+                    key def)))))
+
+(defmacro setq-local-hook (hook &rest args)
+  "Run `setq-local' on ARGS when running HOOK."
   (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
+  (let ((fn (intern (format "%s-setq-local" hook))))
+    (when (and (fboundp fn)
+               (functionp fn))
+      (setq args (append (function-get fn 'setq-local-hook-settings) args)))
+    (unless (and (< 0 (length args))
+                 (zerop (mod (length args) 2)))
+      (user-error "Wrong number of arguments: %S" (length args)))
+    `(progn
+       (defun ,fn ()
+         ,(format "Set local variables after `%s'." hook)
+         (setq-local ,@args))
+       (function-put ',fn 'setq-local-hook-settings ',args)
+       (add-hook ',hook #',fn))))
+
+(unless (fboundp 'ensure-list)
+  ;; Just in case we're using an old version of Emacs.
+  (defun ensure-list (object)
+  "Return OBJECT as a list.
+If OBJECT is already a list, return OBJECT itself.  If it's
+not a list, return a one-element list containing OBJECT."
+  (if (listp object)
+      object
+    (list object))))
+
+(defun add-to-list* (lists &rest things)
+  "Add THINGS to LISTS.
+LISTS can be one list variable or a list.
+Each thing of THINGS can be either a variablel (the thing), or a list of the form
+(ELEMENT &optional APPEND COMPARE-FN), which is passed to
+`add-to-list'."
+  (dolist (l (ensure-list lists))
+    (dolist (thing things)
+      (apply #'add-to-list l (ensure-list thing)))))
+
+(defun add-hook* (hooks &rest functions)
+  "Add FUNCTIONS to HOOKS.
+Each function in FUNCTIONS can be a singleton or a list of the
+form (FUNCTION &optional DEPTH LOCAL)."
+  (dolist (hook (ensure-list hooks))
+    (dolist (fn functions)
+      (apply #'add-hook hook (ensure-list fn)))))