From 093ffa5fbf7143f4668bb0a3dc9659a5cc836e12 Mon Sep 17 00:00:00 2001 From: Yuchen Pei Date: Sat, 17 Jun 2023 17:20:29 +1000 Subject: Moving things one level deeper To ease gnu stow usage. Now we can do stow -t ~ emacs --- emacs/.emacs.d/lisp/my/my-buffer.el | 448 ++++++++++++++++++++++++++++++++++++ 1 file changed, 448 insertions(+) create mode 100644 emacs/.emacs.d/lisp/my/my-buffer.el (limited to 'emacs/.emacs.d/lisp/my/my-buffer.el') diff --git a/emacs/.emacs.d/lisp/my/my-buffer.el b/emacs/.emacs.d/lisp/my/my-buffer.el new file mode 100644 index 0000000..5ff09a7 --- /dev/null +++ b/emacs/.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 +;; Protesilaos Stavrou +;; Maintainer: Yuchen Pei +;; 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 . + +;;; 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: +;; . + +(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 -- cgit v1.2.3