aboutsummaryrefslogtreecommitdiff
path: root/emacs/.emacs.d/lisp/my/my-buffer.el
blob: 5ff09a7d9d6da336cc78e610032cc5beee650f3e (plain) (blame)
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
;;; my-buffer.el -- Buffers and windows related extensions for emacs core -*- lexical-binding: t -*-

;; Copyright (C) 2023 Free Software Foundation.

;; Author: Yuchen Pei <id@ypei.org>
;;         Protesilaos Stavrou <info@protesilaos.com>
;; Maintainer: Yuchen Pei <id@ypei.org>
;; Package-Requires: ((emacs "28.2"))

;; This file is part of dotfiles.

;; dotfiles is free software: you can redistribute it and/or modify it under
;; the terms of the GNU Affero General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; dotfiles is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Affero General
;; Public License for more details.

;; You should have received a copy of the GNU Affero General Public
;; License along with dotfiles.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; Extensions on buffers and windows.

;;; Code:

;; Much of the following is from prot-emacs
(defun my-get-major-mode-for-buffer (buffer)
  (buffer-local-value 'major-mode (get-buffer buffer)))

;;; Copied from mastering emacs
;;; https://www.masteringemacs.org/article/demystifying-emacs-window-manager
(defun my-buffer-make-display-matcher (major-modes)
  (lambda (buffer-name action)
    (with-current-buffer buffer-name (apply #'derived-mode-p major-modes))))

(defun my-get-buffer-modes ()
  (let ((results))
    (dolist (buffer (buffer-list) results)
      (add-to-list 'results (my-get-major-mode-for-buffer buffer)))))

(defun my-switch-to-buffer-matching-major-mode (mode)
  (interactive
   (list (intern (completing-read "Major mode: "
		                              (mapcar 'prin1-to-string (my-get-buffer-modes))))))
  (switch-to-buffer
   (read-buffer "Switch to buffer: " nil t
		            (lambda (pair)
		              (with-current-buffer (cdr pair)
                    (derived-mode-p mode))))))

(defun my--buffer-major-mode-prompt ()
  "Prompt of `my-buffers-major-mode'."
  (let ((major major-mode)
        (read-buffer-function nil))
    (read-buffer
     (format "Buffer for %s: " major)
     nil t
     (lambda (pair)                     ; pair is (name-string . buffer-object)
       (with-current-buffer (cdr pair) (derived-mode-p major))))))

;;;###autoload
(defun my-buffers-major-mode (&optional arg)
  "Select BUFFER matching the current one's major mode.

With a prefix-arg, prompt for major mode."
  (interactive "P")
  (if arg
      (call-interactively 'my-switch-to-buffer-matching-major-mode)
    (switch-to-buffer (my--buffer-major-mode-prompt))))

(defun my-buffer-quick-major-mode (mode)
  "Switch to the first buffer of a given mode."
  (let ((buffers (buffer-list)))
    (while (and buffers
                (with-current-buffer (car buffers)
                  (not (derived-mode-p mode))))
      (setq buffers (cdr buffers)))
    (if buffers
        (pop-to-buffer (car buffers))
      (message "No buffers in %S" mode))))

(defun my-buffer-switch-or-create-major-mode (mode)
  "Switch to or create a buffer with a chosen major mode.

Prompt for a major mode, then:
With no prefix: switch to the first buffer of the chosen major mode.
With one prefix: prompt for a buffer of the chosen major mode.
With two prefixes: create a buffer of the chosen major mode."
  (interactive (list (my-read-major-mode)))
  (pcase (prefix-numeric-value current-prefix-arg)
    (16 (my-buffer-create-major-mode mode))
    (4 (my-switch-to-buffer-matching-major-mode (print mode)))
    (_ (my-buffer-quick-major-mode mode))))

(defvar my-buffer-create-functions nil
  "List indicating ways to create new buffer for a function, each
  element in the form of (major-mode-name
  . buffer-create-function). without specifying, the default
  buffer-create-function is `my-buffer-create-scratch'.")

(defun my-read-major-mode ()
  (intern
   (completing-read
    "Major mode: "
    (cl-loop for sym symbols of obarray
             when (and (functionp sym)
                       ;; we would like to include all modes
                       (provided-mode-derived-p
                        sym
                        'text-mode 'prog-mode
                        'comint-mode 'special-mode))
             collect sym))))

(defun my-buffer-create-major-mode (mode)
  (if (alist-get mode my-buffer-create-functions)
      (call-interactively (alist-get mode my-buffer-create-functions))
    (my-buffer-scratch-setup "" mode)))

(defun my-buffer-create-same-mode (&optional arg)
  (interactive "P")
  (let ((mode (if arg
                  (my-read-major-mode)
                major-mode)))
    (my-buffer-create-major-mode mode)))

(defvar my-buffers-same-mode nil
  "Buffers of the same mode for cycling")

(defun my-buffer-with-same-major-mode-p (other-buffer)
  (let ((mode major-mode))
    (with-current-buffer other-buffer
      (derived-mode-p mode))))

(defun my-buffer-cycle-same-mode ()
  (interactive)
  (unless (and (eq last-command 'my-buffer-create-or-cycle-same-mode)
               (= 1 (prefix-numeric-value last-prefix-arg)))
    (setq my-buffers-same-mode
          (seq-filter 'my-buffer-with-same-major-mode-p (buffer-list))))
  (setq my-buffers-same-mode
        (my-list-cycle my-buffers-same-mode))
  (switch-to-buffer (car my-buffers-same-mode)))

(defun my-buffer-create-or-cycle-same-mode (&optional arg)
  "Create or switch to a buffer of the same major mode

No prefix: cycle
One prefix: switch to buffer with prompt by calling `my-buffers-major-mode'
Two prefixes: create a buffer by calling `my-buffer-create-same-mode'
"
  (interactive "P")
  (pcase (prefix-numeric-value arg)
    (16 (my-buffer-create-same-mode))
    (4 (my-buffers-major-mode))
    (_ (my-buffer-cycle-same-mode))))

(defun my-copy-buffer-file-name ()
  (interactive)
  (when buffer-file-name)
  (kill-new (abbreviate-file-name buffer-file-name))
  (message "Copied %s" (abbreviate-file-name buffer-file-name)))

;;;###autoload
(defun my-kill-buffer (&optional arg)
  "Kill current buffer.
With optional prefix ARG (\\[universal-argument]) choose which
buffer to kill."
  (interactive "P")
  (let ((kill-buffer-query-functions nil))
    (if arg
        (call-interactively 'kill-buffer)
      (kill-buffer))))

;;;###autoload
(defun my-rename-file-and-buffer (name)
  "Apply NAME to current file and rename its buffer.
Do not try to make a new directory or anything fancy."
  (interactive
   (list (read-file-name "Rename current file: " (buffer-file-name))))
  (let ((file (buffer-file-name)))
    (if (vc-registered file)
        (vc-rename-file file name)
      (rename-file file name))
    (set-visited-file-name name t t)))

(defun my--buffer-vc-root-prompt ()
  "Prompt of `my-buffers-vc-root'."
  (let ((root (expand-file-name
               (or (vc-root-dir)
                   (locate-dominating-file "." ".git"))))
        (read-buffer-function nil))
    (read-buffer
     (format "Buffers in %s: " root)
     nil t
     (lambda (pair) ; pair is (name-string . buffer-object)
       (with-current-buffer (cdr pair)
         (string-match-p root default-directory))))))

;;; from prot-emacs
;;;###autoload
(defun my-buffers-vc-root ()
  "Select buffer matching the current one's VC root."
  (interactive)
  (switch-to-buffer (my--buffer-vc-root-prompt)))

(defun my-bookmark-save-no-prompt (&rest _)
    "Run `bookmark-save' without prompts.

The intent of this function is to be added as an :after advice to
`bookmark-set-internal'.  Concretely, this means that when
`bookmark-set-internal' is called, this function is called right
afterwards.  We set this up because there is no hook after
setting a bookmark and we want to automatically save bookmarks at
that point."
    (funcall 'bookmark-save))

(defun my-cycle-windows ()
  "Cycle all windows."
  (interactive)
  (let* ((windows (window-list nil 0))
         (first-window (pop windows))
         (buffer (window-buffer first-window))
         (temp-buffer)
         (window))
    (when windows (select-window (car windows)))
    (dolist (window windows)
      (setq temp-buffer (window-buffer window))
      (set-window-buffer window buffer)
      (setq buffer temp-buffer))
    (set-window-buffer first-window buffer)))

(defun my-focus-write ()
  "Make the current window the only one centered with width 80."
  (interactive)
  (delete-other-windows)
  (let ((margin (/ (- (window-width) 80) 2)))
    (set-window-margins nil margin margin)))

(defun my-select-new-window-matching-mode (mode)
  "Select a new window."
  (setq available-windows
        (delete (selected-window) (window-list)))
  (setq new-window
        (or (cl-find-if (lambda (window)
                       (equal (my-get-major-mode-for-buffer
                               (window-buffer window))
                              mode))
                        available-windows)
            (car available-windows)
            (split-window-sensibly)
            (split-window-right)))
  (select-window new-window))

(defun my-toggle-lock-current-window-to-buffer ()
  (interactive)
  (my-toggle-lock-window-to-buffer (selected-window)))

(defun my-toggle-lock-window-to-buffer (window)
  (if (window-dedicated-p window)
      (progn (set-window-dedicated-p window nil)
             (message "Window unlocked."))
    (set-window-dedicated-p window t)
    (message "Window locked.")))

;; https://lists.gnu.org/archive/html/help-gnu-emacs/2010-01/msg00058.html
(defun my-increase-default-face-height (&optional steps)
  "Increase the height of the default face by STEPS steps.
   Each step multiplies the height by 1.2; a negative number of steps
   decreases the height by the same amount."
  (interactive
   (list
    (cond ((eq current-prefix-arg '-) -1)
          ((numberp current-prefix-arg) current-prefix-arg)
          ((consp current-prefix-arg) -1)
          (t 1))))
  (let ((frame (selected-frame)))
    (set-face-attribute 'default frame
                        :height (floor
                                 (* (face-attribute 'default :height frame)
                                    (expt 1.05 steps))))))

(defun my-decrease-default-face-height (&optional steps)
  "Decrease the height of the default face by STEPS steps.
   Each step divides the height by 1.2; a negative number of steps
   increases the height by the same amount."
  (interactive
   (list
    (cond ((eq current-prefix-arg '-) -1)
          ((numberp current-prefix-arg) current-prefix-arg)
          ((consp current-prefix-arg) -1)
          (t 1))))
  (my-increase-default-face-height (- steps)))

;; if file link points to the same file, do not open in other window
(defun my-find-file-maybe-other-window (filename)
  (if (equal buffer-file-name (expand-file-name filename))
      (find-file filename)
    (find-file-other-window filename)))

(defun my-buffer-empty-p ()
  "Test whether the buffer is empty."
  (or (= (point-min) (point-max))
      (save-excursion
        (goto-char (point-min))
        (while (and (looking-at "^\\([a-zA-Z]+: ?\\)?$")
                    (zerop (forward-line 1))))
        (eobp))))

;;;; Scratch buffers
;; The idea is based on the `scratch.el' package by Ian Eure:
;; <https://github.com/ieure/scratch-el>.

(defun my-buffer-scratch-list-modes ()
  "List known major modes."
  (cl-loop for sym symbols of obarray
           when (and (functionp sym)
                     (or (provided-mode-derived-p sym 'text-mode)
                         (provided-mode-derived-p sym 'prog-mode)))
           collect sym))

(defun my-buffer-scratch-setup (region &optional mode)
  "Add contents to `scratch' buffer and name it accordingly.

REGION is added to the contents to the new buffer.

Use the current buffer's major mode by default.  With optional
MODE use that major mode instead."
  (unless (provided-mode-derived-p mode 'text-mode 'prog-mode)
    (error "Cannot create a scratch with %s which is not derived from
text- or prog-mode." mode))
  (let* ((major (or mode major-mode))
         (string (format "Scratch buffer for: %s\n\n" major))
         (text (concat string region))
         (buf (format "*%s scratch*" major)))
    (with-current-buffer (pop-to-buffer buf)
      (funcall major)
      (if (my-buffer-empty-p)
          ;; We could use `save-restriction' for narrowed buffers, but
          ;; it is overkill.
          (progn
            (insert text)
            (goto-char (point-min))
            (comment-region (line-beginning-position) (line-end-position))
            (goto-char (point-max)))
        (goto-char (point-max))
        (when (my-line-regexp-p 'non-empty)
          (insert "\n\n"))
        (insert region)))))

;;;###autoload
(defun my-buffer-create-scratch (&optional arg)
  "Produce a scratch buffer matching the current major mode.

With optional ARG as a prefix argument (\\[universal-argument]),
use `my-scratch-buffer-default-mode'.

With ARG as a double prefix argument, prompt for a major mode
with completion.  Candidates are derivatives of `text-mode' or
`prog-mode'.

If region is active, copy its contents to the new scratch
buffer.

Buffers are named as *MAJOR-MODE scratch*.  If one already exists
for the given MAJOR-MODE, any text is appended to it."
  (interactive "P")
  (let* ((default-mode my-scratch-buffer-default-mode)
         (modes (my-buffer-scratch-list-modes))
         (region (with-current-buffer (current-buffer)
                   (if (region-active-p)
                       (buffer-substring-no-properties
                        (region-beginning)
                        (region-end))
                     "")))
         mode)
    (pcase (prefix-numeric-value arg)
      (16 (progn
            (setq mode (intern (completing-read "Select major mode: " modes nil t)))
            (my-buffer-scratch-setup region mode)))
      (4 (my-buffer-scratch-setup region default-mode))
      (_ (my-buffer-scratch-setup region)))))

(defcustom my-scratch-buffer-default-mode 'org-mode
  "Default major mode for `my-buffer-create-scratch'."
  :type 'symbol
  :group 'my)

(defun my-base-buffer (&optional buffer)
  "Get the base buffer of BUFFER."
  (setq buffer (or buffer (current-buffer)))
  (unless (bufferp buffer) (error "Not a buffer."))
  (or (buffer-base-buffer buffer) buffer))

(defun my-buffer-with-same-base-p (other-buffer &optional buffer)
  "Test that buffer has the same base buffer as the current buffer."
  (equal (my-base-buffer other-buffer)
         (my-base-buffer buffer)))

(defun my-switch-indirect-buffer ()
  (interactive)
  (let* ((current (current-buffer))
         (buffer
          (read-buffer "Switch to indirect buffer: " nil t
                       (lambda (buffer)
                         (and
                          (my-buffer-with-same-base-p
                           (cdr buffer) current)
                          (not (equal (cdr buffer) current)))))))
    (switch-to-buffer buffer)))

(defun my-list-cycle (xs)
  "Cycle a list."
  (cdr (append xs (list (car xs)))))

(defvar my-indirect-buffer-list nil)

(defun my-cycle-indirect-buffer ()
  (interactive)
  (unless (and (eq last-command 'my-create-or-switch-indirect-buffers)
               (= 1 (prefix-numeric-value last-prefix-arg)))
    (setq my-indirect-buffer-list
          (seq-filter 'my-buffer-with-same-base-p (buffer-list))))
  (setq my-indirect-buffer-list
        (my-list-cycle my-indirect-buffer-list))
  (switch-to-buffer (car my-indirect-buffer-list)))

(defun my-create-or-switch-indirect-buffers (arg)
  "Create or switch to an indirect buffer of the current buffer.

With no prefix, cycle through indirect buffers.

With optional ARG as a prefix argument (\\[universal-argument]),
prompt for indirect buffer to choose from.

With double prefix arguments, create a new indirect buffer."
  (interactive "P")
  (pcase (prefix-numeric-value arg)
    (16 (clone-indirect-buffer nil t))
    (4 (my-switch-indirect-buffer))
    (_ (my-cycle-indirect-buffer))))

(provide 'my-buffer)
;;; my-buffer.el ends here