1;;; ~/.emacs.d/early-init.el -*- lexical-binding: t; -*-
2;; Author: Case Duckworth <acdw@acdw.net>
3;; In this file there are custom functions and macros and early-init settings,
4;; all alphabetically ordered.
5
6(require 'cl-lib)
7
8(define-advice finger (:override (user host) acdw-fix)
9 ;; There is a bug in M-x finger
10 "Finger USER on HOST.
11This command uses `finger-X.500-host-regexps'
12and `network-connection-service-alist', which see."
13 ;; One of those great interactive statements that's actually
14 ;; longer than the function call! The idea is that if the user
15 ;; uses a string like "pbreton@cs.umb.edu", we won't ask for the
16 ;; host name. If we don't see an "@", we'll prompt for the host.
17 (interactive
18 (let* ((answer (let ((default (ffap-url-at-point)))
19 (read-string (format-prompt "Finger User" default)
20 nil nil default)))
21 (index (string-match (regexp-quote "@") answer)))
22 (if index
23 (list (substring answer 0 index)
24 (substring answer (1+ index)))
25 (list answer
26 (let ((default (ffap-machine-at-point)))
27 (read-string (format-prompt "At Host" default)
28 nil nil default))))))
29 (let* ((user-and-host (concat user "@" host))
30 (process-name (concat "Finger [" user-and-host "]"))
31 (regexps finger-X.500-host-regexps)
32 ) ;; found
33 (and regexps
34 (while (not (string-match (car regexps) host))
35 (setq regexps (cdr regexps))))
36 (when regexps
37 (setq user-and-host user))
38 (run-network-program
39 process-name
40 host
41 (cdr (assoc 'finger network-connection-service-alist))
42 user-and-host)))
43
44(define-minor-mode fixed-pitch-mode
45 ;; vendored from https://github.com/cstby/fixed-pitch-mode
46 "Use monospace typeface in the current buffer."
47 :lighter ""
48 (if fixed-pitch-mode
49 (buffer-face-set 'fixed-pitch)
50 (buffer-face-set)))
51
52(defmacro after (events &rest body)
53 (declare (indent 1))
54 (when (cl-some #'listp body)
55 (setq body `((lambda (&rest args) ,@body))))
56 `(progn
57 ,@(cl-loop for event in (ensure-list events)
58 collect
59 (pcase event
60 ((or `(timer ,ev)
61 (pred numberp))
62 `(progn
63 ,@(cl-loop for fn in body collect
64 `(run-with-timer ',(or ev event) nil #',fn))))
65 ((or `(hook ,ev)
66 (pred (lambda (e)
67 (and (symbolp e)
68 (let ((name (symbol-name e)))
69 (or (string-suffix-p "-hook" name)
70 (string-suffix-p "-function" name)
71 (string-suffix-p "-functions" name)))))))
72 `(progn
73 ,@(cl-loop for fn in body collect
74 `(add-hook ',(or ev event) #',fn))))
75 (`(idle ,ev)
76 `(progn
77 ,@(cl-loop for fn in body collect
78 `(run-with-idle-timer ',event nil #',fn))))
79 (`init
80 `(progn
81 ,@(cl-loop for fn in body collect
82 `(add-hook 'after-init-hook #',fn))))
83 ((pred symbolp)
84 `(progn
85 ,@(cl-loop for fn in body collect
86 `(eval-after-load ',event #',fn))))
87 (_ (error "Can't determine event type for `%s'" event))))))
88
89;; (defmacro after (event &rest body)
90;; "Do BODY after EVENT, which can be:
91;; - A feature
92;; - A hook -- if it requires arguments they'll be in the list `args'
93;; - The symbol 'init, which runs on after-init-hook"
94;; (declare (indent 1))
95;; (let ((lambda-form `(lambda (&rest args) ,@body)))
96;; (pcase event
97;; (`(timer ,ev) `(run-with-timer ,ev nil ,lambda-form))
98;; (`(idle ,ev) `(run-with-idle-timer ,ev nil ,lambda-form))
99;; (`(hook ,ev) `(add-hook ',ev ,lambda-form))
100;; (`init `(after (hook after-init-hook) ,@body))
101;; ((pred numberp) `(after (timer ,event) ,@body))
102;; ((pred (lambda (ev)
103;; (and (symbolp ev)
104;; (let ((name (symbol-name ev)))
105;; (or (string-suffix-p "-hook" name)
106;; (string-suffix-p "-function" name)
107;; (string-suffix-p "-functions" name))))))
108;; `(after (hook ,event) ,@body))
109;; ((pred symbolp) `(with-eval-after-load ',event ,@body))
110
111;; (_ (error "Can't determine event type" event)))))
112
113(defmacro find-user-file (name &optional file-name)
114 "Template macro to generate user file finding functions."
115 (declare (indent 1))
116 (let ((file-name (or file-name (intern (format "user-%s-file" name))))
117 (func-name (intern (format "find-user-%s-file" name))))
118 `(defun ,func-name (&optional arg)
119 ,(format "Edit `%s' in the current window.
120With ARG, edit in the other window." file-name)
121 (interactive "P")
122 (funcall (if arg #'find-file-other-window #'find-file)
123 ,file-name))))
124
125(defmacro inhibit-messages (&rest body)
126 "Inhibit all messages in BODY."
127 (declare (indent defun))
128 `(cl-letf (((symbol-function 'message) #'ignore))
129 ,@body))
130
131;; This needs to be a macro to take advantage of setf magic
132(defmacro setf/alist (alist key val &optional testfn)
133 (declare (indent 2))
134 `(setf (alist-get ,key ,alist nil nil (or ,testfn #'equal))
135 ,val))
136
137(defun keyboard-quit-dwim () ; yoinked from protesilaos
138 "Do What I Mean behavior for a general `keyboard-quit'.
139The DWIM behavior is as follows:
140
141- When the region is active, disable it.
142- When the Completions buffer is selected, close it.
143- When a minibuffer is open but not focused, close it.
144- Otherwise, call `keyboard-quit'."
145 (interactive)
146 (cond
147 ((region-active-p)
148 (keyboard-quit))
149 ((derived-mode-p 'completion-list-mode)
150 (delete-completion-window))
151 ((> (minibuffer-depth) 0)
152 (abort-recursive-edit))
153 (t
154 (keyboard-quit))))
155
156(defmacro with-package (pkgspec &rest body)
157 "Perform BODY iff `package-ensure' on PKGSPEC returns non-nil."
158 (declare (indent 1))
159 (let ((pkgspec (ensure-list pkgspec)))
160 `(when (package-ensure ',(car pkgspec) ,@(cdr pkgspec))
161 (prog1 ',pkgspec
162 ,@body))))
163
164(defun ^local-hook (hook fn)
165 "Hook FN to HOOK locally in a lambda.
166Good for adding to an add-hook."
167 (lambda () (add-hook hook fn t)))
168
169(defun ^local-unhook (hook fn)
170 "Remove FN from HOOK locally."
171 (lambda () (remove-hook hook fn t)))
172
173(defun ^turn-off (mode)
174 "Higher-order function: returns a lambda to turn off MODE."
175 (lambda ()
176 (funcall mode -1)))
177
178(defun add-hooks (hook &rest funs) ; TESTING
179 (declare (indent 1))
180 (dolist (fun funs)
181 (add-hook hook fun)))
182
183(defun create-missing-directories ()
184 "Automatically create missing directories."
185 (let ((target-dir (file-name-directory buffer-file-name)))
186 (unless (file-exists-p target-dir)
187 (make-directory target-dir :parents))))
188
189(defun custom-show-all-widgets ()
190 "toggle all \"More/Hide\" widgets in the current buffer."
191 ;; From unpackaged
192 (interactive)
193 (widget-map-buttons (lambda (widget _)
194 (pcase (widget-get widget :off)
195 ("More" (widget-apply-action widget)))
196 nil)))
197
198(defun cycle-spacing* (&optional n)
199 "Negate N argument on `cycle-spacing'."
200 (interactive "*p")
201 (cycle-spacing (- n)))
202
203(defun delete-trailing-whitespace-except-current-line ()
204 "Delete all trailing whitespace except current line."
205 (save-excursion
206 (delete-trailing-whitespace (point-min)
207 (line-beginning-position))
208 (delete-trailing-whitespace (line-end-position)
209 (point-max))))
210
211(defun delete-window-dwim ()
212 "Delete the current window or bury its buffer.
213If the current window is alone in its frame, bury the buffer
214instead."
215 (interactive)
216 (unless (ignore-errors (delete-window) t)
217 (bury-buffer)))
218
219(defun first-found-font (&rest cands)
220 "Return the first font of CANDS that is installed, or nil."
221 (cl-loop with ffl = (font-family-list)
222 for font in cands
223 if (member font ffl)
224 return font))
225
226(defun fixup-whitespace ()
227 "Indent the current buffer and (un)`tabify'.
228Whether it tabifies or untabifies depends on `space-indent-modes'."
229 (interactive)
230 (unless (apply #'derived-mode-p fixup-whitespace-dont-modes)
231 (save-mark-and-excursion
232 (indent-region (point-min) (point-max))
233 (if indent-tabs-mode
234 (tabify (point-min) (point-max))
235 (untabify (point-min) (point-max)))
236 (replace-regexp-in-region "
$" "" (point-min) (point-max)))))
237
238(defun hide-minor-mode (mode &optional hook)
239 "Hide MODE from the mode-line.
240HOOK is used to trigger the action, and defaults to MODE-hook."
241 (setf (alist-get mode minor-mode-alist) (list ""))
242 (add-hook (intern (or hook (format "%s-hook" mode)))
243 (lambda () (hide-minor-mode mode))))
244
245(defun insert-date (format)
246 "Insert the current date in FORMAT.
247FORMAT is either a strftime string or one of the symbols
248- iso8601
249- rfc822"
250 (pcase format
251 ('iso8601
252 (insert (format-time-string "%FT%T%z")))
253 ('rfc822
254 (insert (format-time-string "%a, %d %b %Y %H:%M:%S %z")))
255 ((pred stringp)
256 (insert (format-time-string format)))))
257
258(defun insert-lifever ()
259 "Insert a version number corresponding to my week of life."
260 (interactive)
261 (let* ((birthday (date-to-day "1990-07-25"))
262 (today (date-to-day (current-time-string)))
263 (weeks (/ (- today birthday) 7))
264 (days (mod (- today birthday) 7)))
265 (insert (format "%d.%d" weeks days))))
266
267(defun keyboard-quit* (arg)
268 (interactive "P")
269 (if arg
270 (quit-minibuffer)
271 (keyboard-quit)))
272
273(defun kill-buffer-dwim (&optional buffer-or-name)
274 "Kill BUFFER-OR-NAME or the current buffer."
275 (interactive "P")
276 (cond
277 ((bufferp buffer-or-name)
278 (kill-buffer buffer-or-name))
279 ((null buffer-or-name)
280 (kill-current-buffer))
281 (:else
282 (kill-buffer (read-buffer "Kill: " nil :require-match)))))
283
284(defun minibuffer-delete-directory (&optional n)
285 "Delete the last directory in a file-completing minibuffer."
286 ;; Cribbed from `vertico-directory-up' (github.com/minad/vertico)
287 (interactive "p")
288 (let ((here (point))
289 (meta (completion-metadata
290 "" minibuffer-completion-table
291 minibuffer-completion-predicate)))
292 (if (and (> (point) (minibuffer-prompt-end))
293 (eq 'file (completion-metadata-get meta 'category)))
294 (let ((path (buffer-substring-no-properties (minibuffer-prompt-end)
295 (point)))
296 found)
297 (when (string-match-p "\\`~[^/]*/\\'" path)
298 (delete-minibuffer-contents)
299 (insert (expand-file-name path)))
300 (dotimes (_ (or n 1) found)
301 (save-excursion
302 (let ((end (point)))
303 (goto-char (1- end))
304 (when (search-backward "/" (minibuffer-prompt-end) t)
305 (delete-region (1+ (point)) end)
306 (setq found t))))))
307 (backward-kill-word n))))
308
309(defun other-window-dwim (&optional arg)
310 "Switch to another window/buffer.
311Calls `other-window', which see, unless
312- the current window is alone on its frame
313- `other-window-dwim' is called with \\[universal-argument]
314In these cases, switch to the last-used buffer."
315 (interactive "P")
316 (if (or arg (one-window-p))
317 (switch-to-buffer (other-buffer) nil t)
318 (other-window 1)))
319
320(defun package-ensure (pkgspec &optional require no-error)
321 "Install PKGSPEC if it's not already installed.
322PKGSPEC can be a symbol or a list passable to `package-vc-install'.
323If REQUIRE is non-nil, require the package as well.
324If the package isn't found, error---unless NO-ERROR is non-nil."
325 (message "Ensuring package `%s'" pkgspec)
326 (let ((pkg (if (listp pkgspec) (car pkgspec) pkgspec)))
327 (unless (package-installed-p pkg)
328 (if (symbolp pkgspec)
329 (or (ignore-errors ; Try to install the package
330 (package-install pkg)
331 t)
332 (ignore-errors ; Update package repos then try to install
333 (message "Package `%s' not found, refreshing packages" pkg)
334 (package-refresh-contents)
335 (package-install pkg)
336 t)
337 (ignore-errors
338 (message "Package `%s' still not found, trying `%s'"
339 pkg 'pkg-vc-install)
340 (package-vc-install pkgspec)
341 t)
342 (if no-error nil
343 (error "Can't find package: %s" pkg)))
344 (package-vc-install pkgspec)))
345 (if require (require pkg) t)))
346
347(defun popup-eshell (arg)
348 "Popup an eshell buffer in the current window."
349 (interactive "P")
350 (let ((dd default-directory))
351 (eshell arg)
352 (unless (equal dd default-directory)
353 (end-of-buffer)
354 (eshell-bol)
355 (unless (eolp) (insert "# "))
356 (eshell-send-input)
357 (end-of-buffer)
358 (insert "cd '" dd "'")
359 (eshell-send-input))
360 ;; (unless (equal dd default-directory)
361 ;; (setq default-directory dd)
362 ;; ;; Is this a good idea, really?
363 ;; (eshell-bol)
364 ;; (unless (eolp)
365 ;; (insert "# "))
366 ;; (eshell-send-input))
367 ))
368
369(defun pulse@eval (start end &rest _)
370 "ADVICE: makes `pulse-momentary-highlight-region' accept other arities."
371 (pulse-momentary-highlight-region start end))
372
373(defun quit-minibuffer ()
374 (interactive)
375 (switch-to-minibuffer)
376 (minibuffer-keyboard-quit))
377
378(defun regexp-concat (&rest regexps)
379 (string-join regexps "\\|"))
380
381(defun save-buffers-kill* (arg)
382 "Save all the buffers and kill ... something.
383If ARG is 1 (called normally), kill the current terminal.
384If ARG is 4 (with C-u), kill emacs but ask if there are processes running.
385If ARG is 16, kill emacs without asking about processes."
386 (interactive "p")
387 (pcase arg
388 (1 (save-buffers-kill-terminal))
389 (4 (save-buffers-kill-emacs t))
390 (16 (let ((confirm-kill-processes nil)
391 (kill-emacs-query-functions nil)
392 (confirm-kill-emacs nil))
393 (save-buffers-kill-emacs t)))))
394
395(defun setup-faces ()
396 "Setup Emacs faces."
397 ;; Default faces
398 (cl-loop for (face . spec) in *fonts*
399 do (set-face-attribute face nil
400 :family (plist-get spec :family)
401 :height (or (plist-get spec :height)
402 'unspecified)))
403 ;; Specialized fonts
404 (cl-loop with ffl = (font-family-list)
405 for (charset . font)
406 in '((latin . "Noto Sans")
407 (han . "Noto Sans CJK SC Regular")
408 (kana . "Noto Sans CJK JP Regular")
409 (hangul . "Noto Sans CJK KR Regular")
410 (cjk-misc . "Noto Sans CJK KR Regular")
411 (khmer . "Noto Sans Khmer")
412 (lao . "Noto Sans Lao")
413 (burmese . "Noto Sans Myanmar")
414 (thai . "Noto Sans Thai")
415 (ethiopic . "Noto Sans Ethiopic")
416 (hebrew . "Noto Sans Hebrew")
417 (arabic . "Noto Sans Arabic")
418 (gujarati . "Noto Sans Gujarati")
419 (devanagari . "Noto Sans Devanagari")
420 (kannada . "Noto Sans Kannada")
421 (malayalam . "Noto Sans Malayalam")
422 (oriya . "Noto Sans Oriya")
423 (sinhala . "Noto Sans Sinhala")
424 (tamil . "Noto Sans Tamil")
425 (telugu . "Noto Sans Telugu")
426 (tibetan . "Noto Sans Tibetan")
427 ;; emojis
428 (symbol . "Noto Emoji")
429 ;; (symbol . "Noto Color Emoji")
430 (symbol . "Segoe UI Emoji")
431 (symbol . "Apple Color Emoji")
432 (symbol . "FreeSans")
433 (symbol . "FreeMono")
434 (symbol . "FreeSerif")
435 (symbol . "Unifont")
436 (symbol . "Symbola"))
437 if (member font ffl)
438 do (set-fontset-font t charset font)))
439
440(defun sort-sexps (beg end)
441 "Sort sexps in region.
442Comments stay with the code below."
443 ;; From unpackaged
444 (interactive "r")
445 (cl-flet ((skip-whitespace () (while (looking-at (rx (1+ (or space "\n"))))
446 (goto-char (match-end 0))))
447 (skip-both () (while (cond ((or (nth 4 (syntax-ppss))
448 (ignore-errors
449 (save-excursion
450 (forward-char 1)
451 (nth 4 (syntax-ppss)))))
452 (forward-line 1))
453 ((looking-at (rx (1+ (or space "\n"))))
454 (goto-char (match-end 0)))))))
455 (save-excursion
456 (save-restriction
457 (narrow-to-region beg end)
458 (goto-char beg)
459 (skip-both)
460 (cl-destructuring-bind (sexps markers)
461 (cl-loop do (skip-whitespace)
462 for start = (point-marker)
463 for sexp = (ignore-errors
464 (read (current-buffer)))
465 for end = (point-marker)
466 while sexp
467 ;; Collect the real string, then one used for sorting.
468 collect (cons (buffer-substring (marker-position start)
469 (marker-position end))
470 (save-excursion
471 (goto-char (marker-position start))
472 (skip-both)
473 (buffer-substring (point)
474 (marker-position end))))
475 into sexps
476 collect (cons start end)
477 into markers
478 finally return (list sexps markers))
479 (setq sexps (sort sexps (lambda (a b)
480 (string< (cdr a) (cdr b)))))
481 (cl-loop for (real . sort) in sexps
482 for (start . end) in markers
483 do (progn
484 (goto-char (marker-position start))
485 (insert-before-markers real)
486 (delete-region (point) (marker-position end)))))))))
487
488(defun switch-to-other-buffer ()
489 "Switch to the `other-buffer'."
490 (interactive)
491 (switch-to-buffer nil))
492
493(defun twiddle-windows ()
494 "Twiddle the windows a bit.
495Make this window show the `other-buffer', and `other-window' show
496this buffer."
497 (interactive)
498 (switch-to-buffer (other-buffer) nil t)
499 (other-window 1)
500 (switch-to-buffer (other-buffer) nil t)
501 (other-window 1))
502
503(defun unfill-buffer ()
504 (interactive)
505 (unfill-region (point-min) (point-max)))
506
507(defun unfill-buffer/force ()
508 (interactive)
509 (let ((buffer-read-only nil))
510 (unfill-buffer)
511 (visual-line-mode t)))
512
513(defun unfill-paragraph ()
514 (interactive)
515 (let ((fill-column most-positive-fixnum))
516 (fill-paragraph)))
517
518(defun unfill-region (beg end)
519 (interactive "*r")
520 (let ((fill-column most-positive-fixnum))
521 (fill-region beg end)))
522
523(defun vc-jump (arg)
524 "Jump to the current project's VC buffer.
525With ARG, prompt for the directory."
526 (interactive "P")
527 (if arg
528 (let ((current-prefix-arg nil))
529 (call-interactively #'vc-dir))
530 (project-vc-dir)))
531
532(defvar fixup-whitespace-dont-modes '(makefile-mode)
533 "Which modes to not fixup whitespace in.")
534
535(progn
536 (defvar *fonts*
537 ;; If you get a "Bad font: Drafting* Mono 11" error and Emacs just
538 ;; won't start --- even with -Q --- it's because the default GTK font is
539 ;; Drafting* Mono.
540 (let ((fixed "Drafting* Mono")
541 (variable "Inter"))
542 `((default
543 :family ,fixed
544 :height 120)
545 (variable-pitch :family ,variable)
546 (fixed-pitch :family ,fixed)
547 (fixed-pitch-serif :family ,fixed))))
548 (when after-init-time
549 (setup-faces)))
550
551(setopt default-frame-alist
552 '((menu-bar-lines . 0)
553 (tool-bar-lines . 0)
554 (vertical-scroll-bars)
555 (horizontal-scroll-bars)))
556(setopt frame-inhibit-implied-resize t)
557
558(setopt frame-resize-pixelwise t)
559
560(setopt window-resize-pixelwise t)
561
562(when (getenv "IN_EXWM")
563 (add-to-list 'default-frame-alist '(fullscreen . fullboth)))
564
565(when (require 'package)
566 (add-to-list 'package-archives '("melpa" . "https://melpa.org/packages/"))
567 (package-initialize))