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