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
|
;;; acdw.el --- My Emacs extras -*- lexical-binding: t; -*-
;;; Code:
(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 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)))))
;;; 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))))
(provide 'acdw)
;;; acdw.el ends here
|
