first commit

1 files changed, 448 insertions, 0 deletions

diff --git a/.emacs.d/lisp/my/my-buffer.el b/.emacs.d/lisp/my/my-buffer.el
new file mode 100644
index 0000000..5ff09a7
--- /dev/null
+++ b/.emacs.d/lisp/my/my-buffer.el
@@ -0,0 +1,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