summary refs log tree commit diff stats
path: root/lisp/acdw.el
blob: 191cdfb65dc8581fcfd819d6d5de9931cacf43a4 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
;;; 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:

(require 'diary-lib)
(require 'solar)                        ; for +sunrise-sunset

;;; 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)
           (doc-string 3))
  (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))))

(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)))))

(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."
  (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)
  "Perform FUNC on all buffers satisfied by PREDICATE.
By default, act on all buffers.

Both PREDICATE 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 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."
  (let ((pred (or predicate 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 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."
  (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