summary refs log tree commit diff stats
path: root/lisp/acdw.el
blob: 3b178db08cee91e8cf58fcb08a010d82f2740740 (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
;;; acdw.el --- My Emacs extras  -*- lexical-binding: t; -*-

;;; Code:

(require 'cl-lib)
(require 'seq)

(defmacro defdir (name directory &optional docstring makedir)
  "Define a variable and a function NAME expanding to DIRECTORY.
DOCSTRING is applied to the variable; its default is DIRECTORY's
path.  If MAKEDIR is non-nil, the directory and its parents will
be created."
  (declare (indent 2) (doc-string 3))
  `(progn
     (defvar ,name (expand-file-name ,directory)
       ,(concat (or docstring (format "%s" directory)) "\n"
                "Defined by `defdir'."))
     (defun ,name (file &optional mkdir)
       ,(concat "Expand FILE relative to variable `" (symbol-name name) "'.\n"
                "If MKDIR is non-nil, parent directories are created.\n"
                "Defined by `defdir'.")
       (let ((file-name (expand-file-name
                         (convert-standard-filename file) ,name)))
         (when mkdir
           (make-directory (file-name-directory file-name) :parents))
         file-name))
     ,(if makedir
          `(make-directory ,directory :parents)
        `(unless (file-exists-p ,directory)
           (warn "Directory `%s' doesn't exist." ,directory)))))

(defun choose-executable (&rest programs)
  "Return the first of PROGRAMS that exists in the system's $PATH.
Each of PROGRAMS can be a single string, or a list.  If it's a list then its car
will be tested with `executable-find', and the entire list returned.  This
enables passing arguments to a calling function."
  (seq-find (lambda (x)
              (executable-find (car (ensure-list x))))
            programs))

(defun file-string (file)
  "Return the contents of FILE as a string."
  (with-current-buffer (find-file-noselect file)
    (buffer-string)))

(defun unsmartify-region (begin end)
  "Replace \"smart\" punctuation with \"dumb\" counterparts."
  (interactive "*r")
  (save-excursion
    (goto-char begin)
    (while (re-search-forward  "[“”‘’–—]" end t)
      (let ((replace (pcase (match-string 0)
                       ((or "“" "”") "\"")
                       ((or "‘" "’") "'")
                       ("–" "--")
                       ("—" "---"))))
        (replace-match replace nil nil)))))

(defun ++concat (func strings)
  "Concat STRINGS processed by FUNC.
Each of STRINGS can be a bare string or a list.  Strings are
passed through as-is, but lists are passed to FUNC first as
arguments.  Finally, all the resulting strings are `mapconcat'-ed
together.

As a special case, if `:separator' is the first of STRINGS, the
string following will be used as a separator.  Otherwise, a
newline will be used."
  (let (separator)
    (when (eq (car strings) :separator)
      (setq separator (cadr strings)
            strings (cddr strings)))
    (mapconcat (lambda (s)
                 (cond
                  ((listp s) (apply func s))
                  ((stringp s) s)
                  (t (user-error "Bad argument: %S" s))))
               strings
               (or separator "\n"))))

(defun format-concat (&rest strings)
  "Concatenate formatted STRINGS.
Each of STRINGS can be a bare string or a list.  Bare strings are passed as-is
to `mapconcat' for concatenation and separation.  Lists, however, are passed to
`format' first.

If `:separator' is the first of STRINGS, the next string will be
used as a separator."
  (++concat #'format strings))

(defun list-append-removing-duplicates (&rest lists)
  "Append LISTS, removing duplicates from the result.
Any keyword arguments to `cl-remove-duplicates' should come
before the LISTS."
  (let (cl-remove-duplicates-args)
    (while (keywordp (car lists))
      (push (pop lists) cl-remove-duplicates-args)
      (push (pop lists) cl-remove-duplicates-args))
    (apply #'cl-remove-duplicates (apply #'append lists)
           (nreverse cl-remove-duplicates-args))))

(defun mapc-buffers (func &optional predicate)
  "Map FUNC over buffers matching PREDICATE.
Both FUNC and PREDICATE will be executed with no arguments and in
the context of each buffer.

If PREDICATE is nil or not given, map FUNC over all buffers."
  (cl-loop for buf being the buffers
           do (with-current-buffer buf
                (when (and predicate
                           (funcall predicate))
                  (funcall func)))))

(defun mapc-buffers-modes (func &rest modes)
  "Map FUNC over buffers derived from MODES.
FUNC will be executed with no arguments and in the context of
each buffer."
  (mapc-buffers func
                (lambda ()
                  (apply #'derived-mode-p modes))))

(defun find-font (&rest fonts)
  "Return the first font of FONTS that is installed."
  (cl-loop with ffl = (font-family-list)
           for font in fonts
           if (member font ffl)
           return font))

(defmacro progress@around (fn message &optional name)
  "Define :around advice for functions adding a simple progress reporter."
  (let ((orig (gensym))
        (args (gensym))
        (prog (gensym)))
    `(define-advice ,fn (:around (,orig &rest ,args) ,(or name 'progress))
       ,(format "Add a simple progress reporter to %s." fn)
       (let ((,prog (make-progress-reporter
                     ,(format "%s..." (string-remove-suffix "..." message)))))
         (apply ,orig ,args)
         (progress-reporter-done ,prog)))))



;;; Ispell in .dir-locals

;; Let Emacs know a list of strings is safe
(defun +ispell-safe-local-p (list)
  (and (listp list)
       (seq-every-p #'stringp list)))

;; Can I instruct ispell to insert LocalWords in a different file?
;; https://emacs.stackexchange.com/q/31396/2264

;; How can I move all my file-local LocalWords to .dir-locals.el?
;; https://emacs.stackexchange.com/q/31419

;; Adapted from ispell.el:ispell-buffer-local-words
(defun +ispell-buffer-local-words-list ()
  (let (words)
    (or ispell-buffer-local-name
        (setf ispell-buffer-local-name (buffer-name)))
    (save-excursion
      (goto-char (point-min))
      (while (search-forward ispell-words-keyword nil t)
        (let ((end (point-at-eol))
              (ispell-casechars (ispell-get-casechars))
              string)
          (while (re-search-forward " *\\([^ ]+\\)" end t)
            (setf string (match-string-no-properties 1))
            (if (and (< 1 (length string))
                     (equal 0 (string-match ispell-casechars string)))
                (push string words))))))
    words))

;;;###autoload
(defun +ispell-move-buffer-words-to-dir-locals (&optional arg)
  "Move the current buffer-local words to .dir-locals.el.
This function prompts the user to save .dir-locals.el, unless
prefix ARG is non-nil; then it just saves them."
  (interactive "P")
  (unless (buffer-file-name)
    (user-error "Buffer not attached to file"))
  (hack-dir-local-variables)
  (let ((print-level nil)
        (print-length nil))
    (when-let ((new-words (cl-remove-if
                           (lambda (el) (eq el '\.\.\.)) ; XXX: NO IDEA
                                        ; where this came from
                           (list-append-removing-duplicates
                            :test #'string=
                            ispell-buffer-session-localwords
                            (alist-get 'ispell-buffer-session-localwords
                                       dir-local-variables-alist)
                            (alist-get 'ispell-buffer-session-localwords
                                       file-local-variables-alist)
                            (+ispell-buffer-local-words-list)))))
      (save-excursion
        (add-dir-local-variable
         major-mode
         'ispell-buffer-session-localwords
         (setf ispell-buffer-session-localwords
               new-words))
        (when (or arg
                  (y-or-n-p "Save .dir-locals.el?"))
          (save-buffer))
        (bury-buffer))
      (or ispell-buffer-local-name
          (setf ispell-buffer-local-name (buffer-name)))
      (save-excursion
        (goto-char (point-min))
        (while (search-forward ispell-words-keyword nil t)
          (delete-region (point-at-bol) (1+ (point-at-eol))))))))

;;;###autoload
(defun +ispell-move-buffer-words-to-dir-locals-hook ()
  "Convenience function for binding to a hook."
  (+ispell-move-buffer-words-to-dir-locals t))


;;; Comment-or-uncomment-sexp
;; from https://endlessparentheses.com/a-comment-or-uncomment-sexp-command.html

(defun +lisp-uncomment-sexp (&optional n)
  "Uncomment N sexps 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 +lisp-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 +lisp-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))))
      (+lisp-uncomment-sexp n)
    (dotimes (_ (or n 1))
      (+lisp-comment-sexp--raw))))


;;; Random shit

(defun insert-iso-date (&optional arg)
  "Insert current date formatted ISO-8601 style.
When called with \\[universal-argument] \\[insert-iso-date],
include the time.  When called with \\[universal-argument]
\\[universal-argument] \\[insert-iso-date], prompt the user for the
`format-time-string' format to use."
  (interactive "P")
  (insert (format-time-string (pcase arg
                                ('nil "%F")
                                ('(4) "%FT%T%z")
                                (_ (read-string "Time format: "))))))

(defun unfill-paragraph ()
  "Unfill the current paragraph."
  (interactive)
  (let ((fill-column most-positive-fixnum)
        (fill-paragraph-function nil))
    (fill-paragraph)))

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