From a2657993bad828af6743c68931a0e848bfcdec53 Mon Sep 17 00:00:00 2001 From: Case Duckworth Date: Sun, 21 Nov 2021 23:57:41 -0600 Subject: I DECLARE BANKRUPTCY ... 8 Didn't think to do this till pretty .. written, so here we are. --- lisp/acdw.el | 895 +++-------------------------------------------------------- 1 file changed, 36 insertions(+), 859 deletions(-) (limited to 'lisp/acdw.el') diff --git a/lisp/acdw.el b/lisp/acdw.el index 56b661f..b13c9b6 100644 --- a/lisp/acdw.el +++ b/lisp/acdw.el @@ -1,869 +1,46 @@ -;;; 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. +;;; acdw.el --- various meta-whatevers -*- lexical-binding: t -*- ;;; 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))) +;; 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 `+' ! -(defun html-body-div-filter (output backend info) - "Remove wrapping divs generated by Org." - (when (eq backend 'html) - (replace-regexp-in-string - "]*>\n*" "" - output t))) +;; 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. -(defun org-demote-headings (backend) - (while (/= (point) (point-max)) - (org-next-visible-heading 1) - (org-demote-subtree))) +;; Is it perfect? No. Is it fine? Yes. Here it is. -(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))) - (insert "* ORG IS STUPID SOMETIMES\n") - (goto-char (point-min)) - (org-html-export-as-html nil t nil t - (list :with-smart-quotes nil - :with-special-strings t)) - (with-current-buffer "*Org HTML Export*" - (goto-char (point-min)) - (replace-regexp "

.*

" "") - (insert "

" extracted-heading "

") - (flush-lines "^$" (point-min) (point-max)) - (let ((sentence-end-double-space nil)) - (unfill-region (point-min) (point-max))) - (replace-regexp " +" "

" nil (point-min) (point-max)) - (replace-regexp " +

" "

" 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 as ASCII." - (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 - (list :with-smart-quotes t - :with-special-strings t))) - (with-current-buffer "*Org ASCII Export*" - (goto-char (point-min)) - (insert extracted-heading) - (newline 2) - - (replace-regexp org-list-full-item-re "\n\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")))))) - - -;;; 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)))) - -(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)))) - -;;; BLAH - -(defun open-paragraph () - "Open a paragraph after 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." - (interactive) - ;; 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. - (while (not (looking-at "^$")) - (forward-line 1)) - (newline) - (delete-blank-lines) - (newline 2) - (forward-line -1)) +;;; Code: -(defun require/ (feature &optional filename noerror) - "If FEATURE is not loaded, load it from FILENAME. -This function works just like `require', with one crucial -difference: if the FEATURE name contains a slash, the FILENAME -will as well -- unless, of course, FILENAME is set. This allows -for `require/' to require files within subdirectories of -directories of `load-path'. Of course, NOERROR isn't affected by -the change." - (let* ((feature-name (if (symbolp feature) - (symbol-name feature) - feature)) - (filename (or filename - (and (string-match-p "/" feature-name) - feature-name)))) - (require (intern feature-name) filename noerror))) +;;; 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)) + (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)))) (provide 'acdw) ;;; acdw.el ends here -- cgit 1.4.1-21-gabe81