258 lines
8 KiB
EmacsLisp
258 lines
8 KiB
EmacsLisp
;;; scratch.el --- Mode-specific scratch buffers
|
||
|
||
;; Author: Ian Eure <ian.eure@gmail.com>
|
||
;; Version: 1.4
|
||
;; Package-Version: 20220319.1705
|
||
;; Package-Commit: f000648c9663833a76a8de9b1e78c99a9d698e48
|
||
;; Package-Requires: ((emacs "25.1"))
|
||
;; URL: https://github.com/ieure/scratch-el
|
||
;; Keywords: convenience, tools, files
|
||
|
||
;; Copyright (c) 1999-2017, 2019, 2022 Ian Eure <ian.eure@gmail.com>
|
||
;; All rights reserved.
|
||
|
||
;; Redistribution and use in source and binary forms, with or without
|
||
;; modification, are permitted provided that the following conditions
|
||
;; are met:
|
||
|
||
;; 1. Redistributions of source code must retain the above copyright
|
||
;; notice, this list of conditions and the following disclaimer.
|
||
;; 2. Redistributions in binary form must reproduce the above
|
||
;; copyright notice, this list of conditions and the following
|
||
;; disclaimer in the documentation and/or other materials provided
|
||
;; with the distribution.
|
||
|
||
;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS''
|
||
;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||
;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
|
||
;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR
|
||
;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||
;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||
;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
|
||
;; USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
|
||
;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
|
||
;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
|
||
;; OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
|
||
;; SUCH DAMAGE.
|
||
|
||
;;; Commentary:
|
||
;;
|
||
;; Scratch
|
||
;; =======
|
||
;;
|
||
;; Scratch is an extension to Emacs that enables one to create scratch
|
||
;; buffers that are in the same mode as the current buffer. This is
|
||
;; notably useful when working on code in some language; you may grab
|
||
;; code into a scratch buffer, and, by virtue of this extension, do so
|
||
;; using the Emacs formatting rules for that language.
|
||
;;
|
||
;; Scratch is available from MELPA.
|
||
;;
|
||
;;
|
||
;; Usage
|
||
;; =====
|
||
;;
|
||
;; - `M-x scratch' Immediately create a scratch buffer with the same
|
||
;; major mode as the current buffer’s. If the region is active, copy
|
||
;; it to the scratch buffer. If a scratch buffer already exists, pop
|
||
;; to it (and do nothing with the region).
|
||
;;
|
||
;; - `C-u M-x scratch' Prompts for a major mode to create a scratch
|
||
;; buffer with.
|
||
;;
|
||
;;
|
||
;; Binding
|
||
;; =======
|
||
;;
|
||
;; `C-c s' is a good mnemonic binding for scratch-el:
|
||
;;
|
||
;;
|
||
;; (define-key (current-global-map) "\C-cs" #'scratch)
|
||
;;
|
||
;;
|
||
;; Customization
|
||
;; =============
|
||
;;
|
||
;; If you want to customize the behavior of all scratch buffers, you
|
||
;; can place hooks in `scratch-create-buffer-hook'.
|
||
;;
|
||
;; For per-mode customizations, you can add a hook to the mode, and
|
||
;; check `scratch-buffer' inside it. For example, to set a default
|
||
;; title on all `org-mode' scratch buffers, you could do:
|
||
;;
|
||
;;
|
||
;; (add-hook 'org-mode-hook
|
||
;; (lambda ()
|
||
;; (when scratch-buffer
|
||
;; (save-excursion
|
||
;; (goto-char (point-min))
|
||
;; (insert "#+TITLE: Scratch\n\n")))))
|
||
;;
|
||
|
||
;;; History:
|
||
|
||
;; 1999 Ian Eure
|
||
;; Initial version.
|
||
|
||
;; 2010-08-16 Ian Eure
|
||
;; Broke out into its own file.
|
||
|
||
;; 2012-08-30 Ian Eure
|
||
;; Dump current region into new scratch buffer
|
||
|
||
;; 2017-05-23 Ian Eure
|
||
;; Set up *sql* buffers so they know about the inferior process they
|
||
;; were created from.
|
||
;; Add mappings for additional inferior modes.
|
||
;; Fix checkdoc & package-lint issues.
|
||
;;
|
||
;; 2019-03-13 Ian Eure (v1.3)
|
||
;; Add `scratch-create-buffer-hook', which runs any time a new
|
||
;; scratch buffer is created.
|
||
;; Fix an issue where SQL scratch buffers weren't linked to the SQLi
|
||
;; buffers they were created from.
|
||
;; Fix byte-compilation warnings.
|
||
;; Substantially refactor & update code.
|
||
;;
|
||
;; 2022-03-19 Ian Eure (v1.4)
|
||
;; Depend on cl-lib instead of cl.
|
||
;; Address some minor linter complaints.
|
||
|
||
;;; Code:
|
||
|
||
(require 'cl-lib)
|
||
(require 'sql)
|
||
(require 'subr-x)
|
||
|
||
(defgroup scratch nil
|
||
"Scratch buffers."
|
||
:prefix "scratch-"
|
||
:group 'editing)
|
||
|
||
(defcustom scratch-mode-alist
|
||
'((erc-mode . fundamental-mode)
|
||
(sql-interactive-mode . sql-mode)
|
||
(shell-mode . sh-mode)
|
||
(inferior-python-mode . python-mode)
|
||
(inferior-emacs-lisp-mode . emacs-lisp-mode)
|
||
(cider-repl-mode . clojure-mode)
|
||
(inferior-tcl-mode . tcl-mode)
|
||
(inferior-octave-mode . octave-mode))
|
||
"Alist of mappings from major modes to major modes for `scratch'.
|
||
|
||
Some interactive modes don't lend themselves well to scratch buffers;
|
||
this alist is used to change the mode used by `scratch' for those
|
||
buffers."
|
||
|
||
:type '(alist :key-type symbol :value-type symbol))
|
||
|
||
(defcustom scratch-create-buffer-hook nil
|
||
"Hooks to run when creating a scratch buffer."
|
||
:type 'cons)
|
||
|
||
(defvar scratch--history nil
|
||
"History of scratch buffers.")
|
||
|
||
(defvar scratch--major-mode-list nil
|
||
"List of major modes `scratch' may use. See `scratch-list-modes'.")
|
||
|
||
(defvar scratch-parent nil
|
||
"The parent buffer of this scratch buffer.")
|
||
(make-variable-buffer-local 'scratch-parent)
|
||
|
||
;;;###autoload
|
||
(defvar scratch-buffer nil
|
||
"Non-nil if the current buffer is a scratch buffer.")
|
||
(make-variable-buffer-local 'scratch-buffer)
|
||
|
||
(defun scratch--list-modes ()
|
||
"List known major modes."
|
||
(cl-loop for sym the symbols of obarray
|
||
for name = (symbol-name sym)
|
||
when (and (functionp sym)
|
||
(not (member sym minor-mode-list))
|
||
(string-match "-mode$" name)
|
||
(not (string-match "--" name)))
|
||
collect (substring name 0 -5)))
|
||
|
||
(defun scratch--link-sql ()
|
||
"Link a scratch buffer to a SQLi buffer.
|
||
|
||
This sets up the scratch buffer so `sql-send-buffer' etc work as
|
||
expected."
|
||
(let ((product (with-current-buffer scratch-parent sql-product)))
|
||
(setq sql-product product
|
||
sql-buffer scratch-parent)))
|
||
|
||
(defun scratch--link-buffers ()
|
||
"Link a parent and child buffer.
|
||
|
||
When a scratch buffer is created from a mode for an inferior process,
|
||
and has features which rely on knowing the inferior process, link
|
||
them."
|
||
(cond
|
||
((eq (with-current-buffer scratch-parent major-mode) 'sql-interactive-mode)
|
||
(scratch--link-sql))
|
||
(t nil)))
|
||
|
||
(defun scratch--buffer-querymode ()
|
||
"Return the mode to use for a new scratch buffer.
|
||
|
||
When called with a prefix argument, prompt the user."
|
||
(cond
|
||
;; Prompt user for mode
|
||
(current-prefix-arg
|
||
(intern (concat (completing-read
|
||
"Mode: " (scratch--list-modes)
|
||
nil t nil scratch--history)
|
||
"-mode")))
|
||
|
||
;; Overriden mode for ex. sql->sqli, shell->sh
|
||
((assoc major-mode scratch-mode-alist)
|
||
(cdr (assoc major-mode scratch-mode-alist)))
|
||
|
||
;; Default is the current mode
|
||
(t major-mode)))
|
||
|
||
(defun scratch--create (mode name)
|
||
"Create scratch buffer for mode MODE, with base name NAME.
|
||
|
||
Returns the new buffer."
|
||
(let ((scratch-buffer t)
|
||
(parent (current-buffer))
|
||
(contents (when (region-active-p)
|
||
(buffer-substring-no-properties
|
||
(region-beginning) (region-end)))))
|
||
(with-current-buffer (get-buffer-create name)
|
||
(funcall mode)
|
||
(when contents
|
||
(save-excursion (insert contents)))
|
||
|
||
(setq-local scratch-buffer t)
|
||
(unless current-prefix-arg
|
||
(setq-local scratch-parent parent)
|
||
(scratch--link-buffers))
|
||
(run-hooks 'scratch-create-buffer-hook)
|
||
(current-buffer))))
|
||
|
||
;;;###autoload
|
||
(defun scratch (mode)
|
||
"Get a scratch buffer for the MODE.
|
||
|
||
When called interactively with a prefix arg, prompt for the mode."
|
||
(interactive (list (scratch--buffer-querymode)))
|
||
(let* ((name (thread-last (symbol-name mode)
|
||
(replace-regexp-in-string "-mode$" "")
|
||
(format "*%s*")))
|
||
(buf (get-buffer name)))
|
||
|
||
(pop-to-buffer
|
||
(if (bufferp buf)
|
||
buf ; Existing scratch buffer
|
||
|
||
;; New scratch buffer
|
||
(scratch--create mode name)))))
|
||
|
||
(provide 'scratch)
|
||
;;; scratch.el ends here
|