path: root/emacs/.emacs.d/lisp/my/my-buffer.el

;;; 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>
;; 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:

;; Some of the following was from prot-emacs
(defun my-get-major-mode-for-buffer (buffer)
  "Returns the major mode for 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 (my-read-buffer-by-mode)))

(defun my-read-buffer-by-mode (mode)
  (if (eq mode 'shell-mode)
      (my-read-shell-buffer)
    (read-buffer "Switch to buffer: " nil t
		             (lambda (pair)
		               (with-current-buffer (cdr pair)
                     (derived-mode-p mode))))))

;;;###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-read-buffer-by-mode))))

(defun my-buffer-find-mode (mode)
  "Find a buffer of a given MODE not in a live window."
  (seq-find
   (lambda (buffer)
     (and
      (with-current-buffer buffer
        (derived-mode-p mode))
      (not (my-buffer-live-window-p buffer))))
   (buffer-list)))

(defun my-buffer-quick-major-mode (mode)
  "Switch to the first buffer of a given MODE not in a live window."
  (if-let ((buffer_ (my-buffer-find-mode mode)))
      (switch-to-buffer buffer)
    (message "No non-live-window 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 ()
  "Read a major-mode in a prompt"
  (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
                        'diff-mode 'conf-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-buffer-live-window-p (buffer)
  "Whether BUFFER is in a live window."
  (window-live-p (get-buffer-window buffer)))

(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-select-new-frame ()
  (select-frame (make-frame)))

(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))))

(defvar my-dedicated-modes nil
  "Modes whose windows will be dedicated")
(defun my-dedicate-windows-by-modes ()
  "Dedicate windows with modes from `my-dedicated-modes'."
  (walk-windows
   (lambda (window)
     (when (with-current-buffer (window-buffer window)
             (apply 'derived-mode-p my-dedicated-modes))
       (set-window-dedicated-p window t)))))

;;;; 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)))

(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