summary refs log tree commit diff stats
path: root/lisp/acdw.el
blob: de2b8e761415793ade6d60b87018f60a60b3d0c5 (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
;;; 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."
  (let ((pred (or predicate t)))
    (dolist (buf (buffer-list))
      (with-current-buffer buf
        (when (if (or (eq (car-safe pred) 'closure)
                      (fboundp pred))
                  (funcall pred)
                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")))))

(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 (derived-mode-p 'special-mode 'lui-mode 'comint-mode)
    ;; 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 "☮ 🫀 🍞")
      (cancel-timer (irc-connection-get conn :flood-timer))))
  (+with-progress "Quitting jabber..."
    (ignore-errors
      (jabber-disconnect)))
  (+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)))))

(provide 'acdw)
;;; acdw.el ends here