546 lines
20 KiB
EmacsLisp
546 lines
20 KiB
EmacsLisp
;;; acdw.el -*- 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:
|
||
|
||
;;; 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)
|
||
"Convenience macro for interfacing with `acdw/system'.
|
||
|
||
When called without arguments, it returns `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 dos2unix (buffer)
|
||
"Replace \r\n with \n in BUFFER."
|
||
(interactive "*b")
|
||
(save-excursion
|
||
(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 expand-file-name-args)
|
||
"Call `expand-file-name' on EXPAND-FILE-NAME-ARGS, returning
|
||
its name if it exists, or NIL otherwise."
|
||
(let ((file (apply #'expand-file-name expand-file-name-args)))
|
||
(if (file-exists-p file)
|
||
file
|
||
nil)))
|
||
|
||
;; (defmacro hook-defun (name hooks &rest forms)
|
||
;; "Define a function NAME that executes FORMS, and add it to
|
||
;; each hook in HOOKS."
|
||
;; (declare (indent 2))
|
||
;; (let ((func-name (intern (concat "hook-defun-" (symbol-name name))))
|
||
;; (hook-list (if (consp hooks) hooks (list hooks)))
|
||
;; (hook-defun-add-hook-list))
|
||
;; `(progn
|
||
;; (defun ,func-name () "Defined by `hook-defun'." ,@forms)
|
||
;; ,@(dolist (hook hook-list hook-defun-add-hook-list)
|
||
;; (push `(add-hook ',hook #',func-name) hook-defun-add-hook-list)))))
|
||
|
||
(defun kill-region-or-backward-word (arg)
|
||
"Kill region if active, or backward word if not."
|
||
(interactive "p")
|
||
(if (region-active-p)
|
||
(kill-region (region-beginning) (region-end))
|
||
(backward-kill-word arg)))
|
||
|
||
(defmacro when-unfocused (name &rest forms)
|
||
"Define a function NAME, executing FORMS, that fires 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-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)))
|
||
|
||
|
||
;;; Comment-or-uncomment-sexp
|
||
;; from https://endlessparentheses.com/a-comment-or-uncomment-sexp-command.html
|
||
|
||
(defun uncomment-sexp (&optional n)
|
||
"Uncomment a sexp 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
|
||
|
||
(defun sort-sexps (beg end)
|
||
"Sort sexps in region.
|
||
Comments stay with the code below."
|
||
(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)
|
||
(buffer-substring (point) (marker-position end))))
|
||
into sexps
|
||
collect (cons start end)
|
||
into markers
|
||
finally return (list sexps markers))
|
||
(setq sexps (sort sexps (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, 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/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-dotfiles ()
|
||
"Finds lisp files in `user-emacs-directory' and passes them to
|
||
`completing-read'."
|
||
(interactive)
|
||
(find-file (completing-read ".emacs: "
|
||
(directory-files-recursively
|
||
user-emacs-directory "\.el$"))))
|
||
|
||
(defun acdw/find-emacs-source ()
|
||
"Find where Emacs keeps its source tree."
|
||
(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 (with-time)
|
||
"Insert the ISO-8601-formatted date, with optional time."
|
||
(interactive "P")
|
||
(let ((format (if with-time "%FT%T%z" "%F")))
|
||
(insert (format-time-string format (current-time)))))
|
||
|
||
(defun acdw/kill-a-buffer (&optional prefix)
|
||
"Kill a buffer based on the following rules:
|
||
|
||
C-x k => Kill CURRENT buffer and window
|
||
C-u C-x k => Kill OTHER buffer and window
|
||
C-u C-u C-x k => 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 commands at sunrise and 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 (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/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"))))))
|
||
|
||
|
||
;;; URL regexp
|
||
;; really, I just want to add gemini:// protocol, but I'm going to do some
|
||
;; reverse-engineering here.
|
||
|
||
(defvar acdw/button-protocols '("http"
|
||
"https"
|
||
"shttp"
|
||
"shttps"
|
||
"ftp"
|
||
"file"
|
||
"gopher"
|
||
"nntp"
|
||
"news"
|
||
"telnet"
|
||
"wais"
|
||
"mailto"
|
||
"info")
|
||
"The list of protocols to splice into `browse-url-button-regexp'.")
|
||
|
||
(defun acdw/build-button-url-regexp ()
|
||
"Build `browse-url-button-regexp' from `acdw/button-protocols'.
|
||
I used `xr' (not included in Emacs) to get the RX form of the
|
||
default, so I can easily splice the list into it. THIS IS
|
||
BRITTLE AF!!!"
|
||
(rx-to-string ; thanks wgreenhouse!
|
||
`(seq word-boundary
|
||
(group
|
||
(group
|
||
(or "www."
|
||
(seq
|
||
(group (or ,@acdw/button-protocols))
|
||
":")))
|
||
(opt
|
||
(group "//"
|
||
(one-or-more
|
||
(any "0-9a-z" "._-"))
|
||
":"
|
||
(zero-or-more
|
||
(any "0-9"))))
|
||
(or
|
||
(seq
|
||
(one-or-more
|
||
(any "0-9a-z" "!#$%&*+,./:;=?@\\_~-" word))
|
||
"("
|
||
(one-or-more
|
||
(any "0-9a-z" "!#$%&*+,./:;=?@\\_~-" word))
|
||
(zero-or-more
|
||
(any "0-9a-z" "#$%&*+/=@\\_~-" word))
|
||
")"
|
||
(opt
|
||
(one-or-more
|
||
(any "0-9a-z" "!#$%&*+,./:;=?@\\_~-" word))
|
||
(any "0-9a-z" "#$%&*+/=@\\_~-" word)))
|
||
(seq
|
||
(one-or-more
|
||
(any "0-9a-z" "!#$%&*+,./:;=?@\\_~-" word))
|
||
(any "0-9a-z" "#$%&*+/=@\\_~-" word)))))))
|
||
|
||
(defun acdw/add-button-url-regexp-protocol (proto)
|
||
"Add PROTO to `browse-url-button-regexp'
|
||
First, add PROTO to `acdw/button-protocols'.
|
||
Then, build `browse-url-button-regexp' with the new protocol."
|
||
(add-to-list 'acdw/button-protocols proto)
|
||
(setq-default browse-url-button-regexp (acdw/build-button-url-regexp)))
|
||
|
||
|
||
;;; 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)
|
||
(if (file-directory-p newname)
|
||
(rjs/recentf-rename-directory oldname newname)
|
||
(rjs/recentf-rename-file oldname newname)))
|
||
|
||
(defun rjs/recentf-rename-file (oldname newname)
|
||
(setq recentf-list
|
||
(mapcar (lambda (name)
|
||
(if (string-equal name oldname)
|
||
newname
|
||
oldname))
|
||
recentf-list)))
|
||
|
||
(defun rjs/recentf-rename-directory (oldname newname)
|
||
;; 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)))
|
||
|
||
|
||
;;; Minor modes
|
||
|
||
(define-minor-mode acdw/reading-mode
|
||
"A mode for reading."
|
||
:init-value nil
|
||
:lighter " Read"
|
||
(if acdw/reading-mode
|
||
(progn ;; turn on
|
||
;; settings
|
||
(setq-local orig-indicate-empty-lines indicate-empty-lines
|
||
indicate-empty-lines nil
|
||
orig-indicate-buffer-boundaries indicate-buffer-boundaries
|
||
indicate-buffer-boundaries nil)
|
||
;; disable modes
|
||
(dolist (mode '(display-fill-column-indicator-mode))
|
||
(when (fboundp mode)
|
||
(funcall mode -1)))
|
||
;; enable modes
|
||
(dolist (mode '(iscroll-mode olivetti-mode))
|
||
(when (fboundp mode)
|
||
(funcall mode +1))))
|
||
;; turn off
|
||
;; settings
|
||
(setq-local indicate-empty-lines orig-indicate-empty-lines
|
||
indicate-buffer-boundaries orig-indicate-buffer-boundaries)
|
||
;; enable modes
|
||
(dolist (mode '(display-fill-column-indicator-mode))
|
||
(when (fboundp mode)
|
||
(funcall mode +1)))
|
||
;; disable modes
|
||
(dolist (mode '(olivetti-mode iscroll-mode))
|
||
(when (fboundp mode)
|
||
(funcall mode -1)))))
|
||
|
||
(provide 'acdw)
|
||
;;; acdw.el ends here
|