From a2657993bad828af6743c68931a0e848bfcdec53 Mon Sep 17 00:00:00 2001 From: Case Duckworth Date: Sun, 21 Nov 2021 23:57:41 -0600 Subject: I DECLARE BANKRUPTCY ... 8 Didn't think to do this till pretty .. written, so here we are. --- lisp/+avy.el | 21 ++ lisp/+circe.el | 148 ++++++++ lisp/+consult.el | 47 +++ lisp/+defaults.el | 239 +++++++++++++ lisp/+dired.el | 8 + lisp/+eshell.el | 80 +++++ lisp/+init.el | 92 +++++ lisp/+lisp.el | 71 ++++ lisp/+org.el | 341 ++++++++++++++++++ lisp/+setup.el | 105 ++++++ lisp/+util.el | 81 +++++ lisp/acdw-apheleia.el | 25 -- lisp/acdw-autoinsert.el | 58 ---- lisp/acdw-bell.el | 28 -- lisp/acdw-browse-url.el | 129 ------- lisp/acdw-circe.el | 167 --------- lisp/acdw-compat.el | 555 ------------------------------ lisp/acdw-consult.el | 93 ----- lisp/acdw-cus-edit.el | 32 -- lisp/acdw-erc.el | 228 ------------ lisp/acdw-eshell.el | 93 ----- lisp/acdw-eww.el | 38 -- lisp/acdw-fonts.el | 176 ---------- lisp/acdw-frame.el | 36 -- lisp/acdw-irc.el | 72 ---- lisp/acdw-lisp.el | 16 - lisp/acdw-modeline.el | 232 ------------- lisp/acdw-org.el | 517 ---------------------------- lisp/acdw-re.el | 151 -------- lisp/acdw-reading.el | 100 ------ lisp/acdw-setup.el | 103 ------ lisp/acdw-ytel.el | 75 ---- lisp/acdw.el | 895 ++---------------------------------------------- lisp/chd.el | 76 ---- lisp/titlecase.el | 157 --------- 35 files changed, 1269 insertions(+), 4016 deletions(-) create mode 100644 lisp/+avy.el create mode 100644 lisp/+circe.el create mode 100644 lisp/+consult.el create mode 100644 lisp/+defaults.el create mode 100644 lisp/+dired.el create mode 100644 lisp/+eshell.el create mode 100644 lisp/+init.el create mode 100644 lisp/+lisp.el create mode 100644 lisp/+org.el create mode 100644 lisp/+setup.el create mode 100644 lisp/+util.el delete mode 100644 lisp/acdw-apheleia.el delete mode 100644 lisp/acdw-autoinsert.el delete mode 100644 lisp/acdw-bell.el delete mode 100644 lisp/acdw-browse-url.el delete mode 100644 lisp/acdw-circe.el delete mode 100644 lisp/acdw-compat.el delete mode 100644 lisp/acdw-consult.el delete mode 100644 lisp/acdw-cus-edit.el delete mode 100644 lisp/acdw-erc.el delete mode 100644 lisp/acdw-eshell.el delete mode 100644 lisp/acdw-eww.el delete mode 100644 lisp/acdw-fonts.el delete mode 100644 lisp/acdw-frame.el delete mode 100644 lisp/acdw-irc.el delete mode 100644 lisp/acdw-lisp.el delete mode 100644 lisp/acdw-modeline.el delete mode 100644 lisp/acdw-org.el delete mode 100644 lisp/acdw-re.el delete mode 100644 lisp/acdw-reading.el delete mode 100644 lisp/acdw-setup.el delete mode 100644 lisp/acdw-ytel.el delete mode 100644 lisp/chd.el delete mode 100644 lisp/titlecase.el (limited to 'lisp') diff --git a/lisp/+avy.el b/lisp/+avy.el new file mode 100644 index 0000000..5010e95 --- /dev/null +++ b/lisp/+avy.el @@ -0,0 +1,21 @@ +;;; +avy.el -*- lexical-binding: t -*- + +;;; Commentary: + +;; https://karthinks.com/software/avy-can-do-anything/ + +;;; Code: + +(require 'avy) + +(defun avy-action-embark (pt) + (unwind-protect + (save-excursion + (goto-char pt) + (embark-act)) + (select-window + (cdr (ring-ref avy-ring 0)))) + t) + +(provide '+avy) +;;; avy.el ends here diff --git a/lisp/+circe.el b/lisp/+circe.el new file mode 100644 index 0000000..1403af8 --- /dev/null +++ b/lisp/+circe.el @@ -0,0 +1,148 @@ +;;; +circe.el -*- lexical-binding: t; -*- + +;;; Code: + +(require '+util) +(require 'circe) + +(defgroup +circe nil + "Extra customizations for Circe." + :group 'circe) + +(defcustom +circe-left-margin 16 + "The size of the margin on the left." + :type 'integer) + +(defcustom +circe-network-inhibit-autoconnect nil + "Servers to inhibit autoconnecting from `circe-network-options'." + :type '(repeat string)) + +;;; Connecting to IRC + +;;;###autoload +(defun +irc () + "Connect to all IRC networks in `circe-network-options'." + (interactive) + (dolist (network (mapcar 'car circe-network-options)) + (unless (member network +circe-network-inhibit-autoconnect) + (+circe-maybe-connect network)))) + +(defun +circe-network-connected-p (network) + "Return t if connected to NETWORK, nil otherwise." + (catch 'return + (dolist (buffer (circe-server-buffers)) + (with-current-buffer buffer + (when (string= network circe-server-network) + (throw 'return t)))))) + +(defun +circe-maybe-connect (network) + "Connect to NETWORK, asking for confirmation to reconnect." + (interactive ("sNetwork: ")) + (when (or (not (+circe-network-connected-p network)) + (yes-or-no-p (format "Already connected to %s, reconnect? " + network))) + (circe network))) + +;;; Channel information + +(defun +circe-current-topic (&optional message) + "Return the topic of the current channel. +When called with optional MESSAGE non-nil, or interactively, also +message the current topic.") + +;;; Formatting messages + +(defun +circe-format-meta (string) + "Return a format string for `lui-format' for metadata messages." + (format "{nick:%1$d.%1$ds} *** %s" (- +circe-left-margin 3) string)) + +;;; Hooks & Advice + +(defun +circe-chat@set-prompt () + "Set the prompt to the (shortened) buffer name." + (interactive) + (lui-set-prompt (propertize (+string-align (buffer-name) +circe-left-margin + :after " > " + :ellipsis "~" + :alignment 'right)))) + +(defun +circe-kill-buffer (&rest _) + "Kill a circe buffer without confirmation, and after a delay." + (let ((circe-channel-killed-confirmation nil) + (circe-server-killed-confirmation nil)) + (run-with-timer 0.25 nil 'kill-buffer))) + +(defun +circe-quit@kill-buffer (&rest _) + "ADVICE: kill all buffers of a server after `circe-command-QUIT'." + (with-circe-server-buffer + (dolist (buf (circe-server-buffers)) + (with-current-buffer buf + (+circe-kill-buffer))) + (+circe-kill-buffer))) + +(defun +circe-gquit@kill-buffer (&rest _) + "ADVICE: kill all Circe buffers after `circe-command-GQUIT'." + (dolist (buf (circe-server-buffers)) + (with-current-buffer buf + (+circe-quit@kill-buffer)))) + +;;; Patches + +(require 'el-patch) + +(el-patch-feature circe) +(defvar circe-server-buffer-action 'pop-to-buffer-same-window + "What to do with `circe-server' buffers when created.") + +(el-patch-defun circe (network-or-server &rest server-options) + "Connect to IRC. + +Connect to the given network specified by NETWORK-OR-SERVER. + +When this function is called, it collects options from the +SERVER-OPTIONS argument, the user variable +`circe-network-options', and the defaults found in +`circe-network-defaults', in this order. + +If NETWORK-OR-SERVER is not found in any of these variables, the +argument is assumed to be the host name for the server, and all +relevant settings must be passed via SERVER-OPTIONS. + +All SERVER-OPTIONS are treated as variables by getting the string +\"circe-\" prepended to their name. This variable is then set +locally in the server buffer. + +See `circe-network-options' for a list of common options." + (interactive (circe--read-network-and-options)) + (let* ((options (circe--server-get-network-options network-or-server + server-options)) + (buffer (circe--server-generate-buffer options))) + (with-current-buffer buffer + (circe-server-mode) + (circe--server-set-variables options) + (circe-reconnect)) + (el-patch-swap (pop-to-buffer-same-window buffer) + (funcall circe-server-buffer-action buffer)))) + +;;; Chat commands + +(defun circe-command-SHORTEN (url) + "Shorten URL using `0x0-shorten-uri'.") + +(defun circe-command-SLAP (nick) + "Slap NICK around a bit with a large trout.") + +;;; Pure idiocy + +(define-minor-mode circe-cappy-hour-mode + "ENABLE CAPPY HOUR IN CIRCE!" + :lighter "CAPPY HOUR" + (when (derived-mode-p 'circe-chat-mode) + (if circe-cappy-hour-mode + (setq-local lui-input-function + (lambda (input) (circe--input (upcase input)))) + ;; XXX: It'd be better if this were more general, but whatever. + (setq-local lui-input-function #'circe--input)))) + +(provide '+circe) +;;; +circe.el ends here diff --git a/lisp/+consult.el b/lisp/+consult.el new file mode 100644 index 0000000..7b6a20f --- /dev/null +++ b/lisp/+consult.el @@ -0,0 +1,47 @@ +;;; +consult.el --- consult additions -*- lexical-binding: t -*- + +;;; Code: + +(defun +consult-project-root () + "Return either the current project, or the VC root, of current file." + (if (and (functionp 'project-current) + (project-current)) + (car (project-roots (project-current))) + (vc-root-dir))) + +;;; Cribbed functions +;; https://github.com/minad/consult/wiki + +(defun consult--orderless-regexp-compiler (input type) + (setq input (orderless-pattern-compiler input)) + (cons + (mapcar (lambda (r) (consult--convert-regexp r type)) input) + (lambda (str) (orderless--highlight input str)))) + +(defmacro consult-history-to-modes (map-hook-alist) + (let (defuns) + (dolist (map-hook map-hook-alist) + (let ((map-name (symbol-name (car map-hook))) + (key-defs `(progn (define-key + ,(car map-hook) + (kbd "M-r") + (function consult-history)) + (define-key ,(car map-hook) + (kbd "M-s") nil)))) + (push (if (cdr map-hook) + `(add-hook ',(cdr map-hook) + (defun + ,(intern (concat map-name + "@consult-history-bind")) + nil + ,(concat + "Bind `consult-history' to M-r in " + map-name ".\n" + "Defined by `consult-history-to-modes'.") + ,key-defs)) + key-defs) + defuns))) + `(progn ,@ (nreverse defuns)))) + +(provide '+consult) +;;; +consult.el ends here diff --git a/lisp/+defaults.el b/lisp/+defaults.el new file mode 100644 index 0000000..ee49480 --- /dev/null +++ b/lisp/+defaults.el @@ -0,0 +1,239 @@ +;;; +defaults.el --- measured defaults for Emacs -*- lexical-binding: t -*- + +;;; Commentary: + +;; I find myself copy-pasting a lot of "boilerplate" type code when +;; bankrupting my Emacs config and starting afresh. Instead of doing +;; that, I'm putting it here, where it'll be easier to include in my +;; config. + +;; Of course, some might say I could just ... stop bankrupting my +;; Emacs. But like, why would I want to? + +;; Other notable packages include +;; https://git.sr.ht/~technomancy/better-defaults/ + +;;; Code: + +(require 'early-init (locate-user-emacs-file "early-init.el")) + +(defun +set-major-mode-from-buffer-name (&optional buf) + "Set the major mode for BUF from the buffer's name. +Do this only if the buffer is not visiting a file." + (unless buffer-file-name + (let ((buffer-file-name (buffer-name buf))) + (set-auto-mode)))) + +;;; General settings + +(setq-default + apropos-do-all t + async-shell-command-buffer 'new-buffer + async-shell-command-display-buffer nil + auto-hscroll-mode 'current-line + auto-revert-verbose nil + auto-save-file-name-transforms `((".*" ,(.etc "auto-save/" t) t)) + auto-save-interval 60 + auto-save-list-file-prefix (.etc "auto-save/.saves-" t) + auto-save-timeout 60 + auto-save-visited-interval 60 + auto-window-vscroll nil + backup-by-copying t + backup-directory-alist `((".*" . ,(.etc "backup/" t))) + blink-cursor-blinks 1 + completion-category-defaults nil + completion-category-overrides '((file (styles . (partial-completion)))) + completion-ignore-case t + completion-styles '(substring partial-completion) + cursor-in-non-selected-windows 'hollow + cursor-type 'bar + custom-file (.etc "custom.el") + delete-old-versions t + echo-keystrokes 0.1 + ediff-window-setup-function 'ediff-setup-windows-plain + eldoc-echo-area-use-multiline-p nil + eldoc-idle-delay 0.1 + enable-recursive-minibuffers t + executable-prefix-env t + fast-but-imprecise-scrolling t + file-name-shadow-properties '(invisible t intangible t) + frame-resize-pixelwise t + global-auto-revert-non-file-buffers t + global-mark-ring-max 100 + hscroll-step 1 + imenu-auto-rescan t + indent-tabs-mode nil + inhibit-startup-screen t + initial-buffer-choice t + kill-do-not-save-duplicates t + kill-read-only-ok t + kill-ring-max 500 + kmacro-ring-max 20 + load-prefer-newer t + major-mode '+set-major-mode-from-buffer-name + mark-ring-max 50 + minibuffer-eldef-shorten-default t + minibuffer-prompt-properties '(read-only t + cursor-intangible t + face minibuffer-prompt) + mode-require-final-newline 'visit-save + mouse-drag-copy-region t + mouse-yank-at-point t + native-comp-async-report-warnings-errors 'silent + read-answer-short t + read-buffer-completion-ignore-case t + read-extended-command-predicate (when + (fboundp + 'command-completion-default-include-p) + 'command-completion-default-include-p) + recenter-positions '(top middle bottom) + regexp-search-ring-max 100 + regexp-search-ring-max 200 + save-interprogram-paste-before-kill t + scroll-conservatively 101 + scroll-preserve-screen-position 1 + scroll-step 1 + search-ring-max 200 + search-ring-max 200 + sentence-end-double-space t + set-mark-command-repeat-pop t + show-paren-delay 0 + show-paren-style 'mixed + show-paren-when-point-in-periphery t + show-paren-when-point-inside-paren t + tramp-backup-directory-alist backup-directory-alist + use-dialog-box nil + use-file-dialog nil + use-short-answers t + vc-follow-symlinks t + vc-make-backup-files t + version-control t + view-read-only t + visible-bell nil + window-resize-pixelwise t + x-select-enable-clipboard t + x-select-enable-primary t + yank-pop-change-selection t + ) + +(when (version< emacs-version "28") + (fset 'yes-or-no-p 'y-or-n-p)) + +;; Encoding -- UTF-8 everywhere +(setq-default locale-coding-system 'utf-8-unix + coding-system-for-read 'utf-8-unix + coding-system-for-write 'utf-8-unix + buffer-file-coding-system 'utf-8-unix + default-process-coding-system '(utf-8-unix . utf-8-unix) + x-select-request-type '(UTF8_STRING + COMPOUND_TEXT + TEXT + STRING)) + +(set-charset-priority 'unicode) +(set-language-environment "UTF-8") +(prefer-coding-system 'utf-8-unix) +(set-default-coding-systems 'utf-8-unix) +(set-terminal-coding-system 'utf-8-unix) +(set-keyboard-coding-system 'utf-8-unix) + +(pcase system-type + ((or 'ms-dos 'windows-nt) + (set-clipboard-coding-system 'utf-16-le) + (set-selection-coding-system 'utf-16-le)) + (_ + (set-selection-coding-system 'utf-8) + (set-clipboard-coding-system 'utf-8))) + +;;; Modes + +(dolist (enable-mode '(global-auto-revert-mode + blink-cursor-mode + electric-pair-mode + show-paren-mode + global-so-long-mode + minibuffer-depth-indicate-mode + file-name-shadow-mode + minibuffer-electric-default-mode + delete-selection-mode + column-number-mode)) + (when (fboundp enable-mode) + (funcall enable-mode +1))) + +(dolist (disable-mode '(tooltip-mode + tool-bar-mode + menu-bar-mode + scroll-bar-mode + horizontal-scroll-bar-mode)) + (when (fboundp disable-mode) + (funcall disable-mode -1))) + +;;; Hooks + +(add-hook 'after-save-hook 'executable-make-buffer-file-executable-if-script-p) +(add-hook 'minibuffer-setup-hook 'cursor-intangible-mode) + +;;; Bindings + +(global-set-key (kbd "M-/") 'hippie-expand) +(global-set-key (kbd "M-=") 'count-words) +(global-set-key (kbd "C-x C-b") 'ibuffer) +(global-set-key (kbd "C-s") 'isearch-forward-regexp) +(global-set-key (kbd "C-r") 'isearch-backward-regexp) +(global-set-key (kbd "C-M-s") 'isearch-forward) +(global-set-key (kbd "C-M-r") 'isearch-backward) + +;;; Required libraries + +(when (require 'uniquify nil :noerror) + (setq-default uniquify-buffer-name-style 'forward + uniquify-separator path-separator + uniquify-after-kill-buffer-p t + uniquify-ignore-buffers-re "^\\*")) + +(when (require 'goto-addr) + (if (fboundp 'global-goto-address-mode) + (global-goto-address-mode +1) + (add-hook 'after-change-major-mode-hook 'goto-address-mode))) + +(when (require 'recentf nil :noerror) + (setq-default recentf-save-file (.etc "recentf.el") + recentf-max-menu-items 100 + recentf-max-saved-items nil + recentf-auto-cleanup 'mode) + (add-to-list 'recentf-exclude .etc) + (recentf-mode +1)) + +(when (require 'repeat nil :noerror) + (setq-default repeat-exit-key "g" + repeat-exit-timeout 5) + (repeat-mode +1)) + +(when (require 'savehist nil :noerror) + (setq-default history-length t + history-delete-duplicates t + history-autosave-interval 60 + savehist-file (.etc "savehist.el")) + (dolist (var '(extended-command-history + global-mark-ring + kill-ring + regexp-search-ring + search-ring + mark-ring)) + (add-to-list 'savehist-additional-variables var)) + (savehist-mode +1)) + +(when (require 'saveplace nil :noerror) + (setq-default save-place-file (.etc "places.el") + save-place-forget-unreadable-files (eq system-type 'gnu/linux)) + (save-place-mode +1)) + +(when (require 'tramp) + ;; thanks Irreal! https://irreal.org/blog/?p=895 + (add-to-list 'tramp-default-proxies-alist + '(nil "\\`root\\'" "/ssh:%h:")) + (add-to-list 'tramp-default-proxies-alist + '((regexp-quote (system-name)) nil nil))) + +(provide '+defaults) +;;; +defaults.el ends here diff --git a/lisp/+dired.el b/lisp/+dired.el new file mode 100644 index 0000000..7decec1 --- /dev/null +++ b/lisp/+dired.el @@ -0,0 +1,8 @@ +;;; +dired.el -*- lexical-binding: t -*- + +;;; Code: + + + +(provide '+dired) +;;; +dired.el ends here diff --git a/lisp/+eshell.el b/lisp/+eshell.el new file mode 100644 index 0000000..bd92b03 --- /dev/null +++ b/lisp/+eshell.el @@ -0,0 +1,80 @@ +;;; +eshell.el -*- lexical-binding: t; -*- + +;;; Code: + +;; https://karthinks.com/software/jumping-directories-in-eshell/ +(defun eshell/z (&optional regexp) + "Navigate to a previously visited directory in eshell, or to +any directory proferred by `consult-dir'." + (let ((eshell-dirs (delete-dups + (mapcar 'abbreviate-file-name + (ring-elements eshell-last-dir-ring))))) + (cond + ((and (not regexp) (featurep 'consult-dir)) + (let* ((consult-dir--source-eshell `(:name "Eshell" + :narrow ?e + :category file + :face consult-file + :items ,eshell-dirs)) + (consult-dir-sources (cons consult-dir--source-eshell + consult-dir-sources))) + (eshell/cd (substring-no-properties + (consult-dir--pick "Switch directory: "))))) + (t (eshell/cd (if regexp (eshell-find-previous-directory regexp) + (completing-read "cd: " eshell-dirs))))))) + +;;; Start and quit + +(defun +eshell-quit-or-delete-char (arg) + "Delete the character to the right, or quit eshell on an empty line." + (interactive "p") + (if (and (eolp) (looking-back eshell-prompt-regexp)) + (eshell-life-is-too-much) + (delete-forward-char arg))) + +;;; Insert previous arguments +;; Record arguments + +(defvar eshell-arg-history nil) +(defvar eshell-arg-history-index nil) +(add-to-list 'savehist-additional-variables 'eshell-arg-history) + +(defun eshell-record-args (&rest _) + "Record unique arguments onto the front of `eshell-arg-history'." + (setq eshell-arg-history + (cl-loop with history = eshell-arg-history + for arg in (reverse eshell-last-arguments) + do (setq history (cons arg (remove arg history))) + finally return history))) + +(defun eshell-insert-prev-arg () + "Insert an argument from `eshell-arg-history' at point." + (interactive) + (if (eq last-command 'eshell-insert-prev-arg) + (progn + (let ((pos (point))) + (eshell-backward-argument 1) + (delete-region (point) pos)) + (if-let ((text (nth eshell-arg-history-index + eshell-arg-history))) + (progn + (insert text) + (cl-incf eshell-arg-history-index)) + (insert (cl-first eshell-arg-history)) + (setq eshell-arg-history-index 1))) + (insert (cl-first eshell-arg-history)) + (setq eshell-arg-history-index 1))) + +;;;###autoload +(define-minor-mode eshell-arg-hist-mode + "Minor mode to enable argument history, like bash/zsh with M-." + :lighter "$." + :keymap (let ((map (make-sparse-keymap))) + (define-key map (kbd "M-.") #'eshell-insert-prev-arg) + map) + (if eshell-arg-hist-mode + (add-hook 'eshell-post-command-hook #'eshell-record-args nil t) + (remove-hook 'eshell-post-command-hook #'eshell-record-args t))) + +(provide '+eshell) +;;; +eshell.el ends here diff --git a/lisp/+init.el b/lisp/+init.el new file mode 100644 index 0000000..3ab0486 --- /dev/null +++ b/lisp/+init.el @@ -0,0 +1,92 @@ +;;; +init.el --- extra init.el stuff -*- lexical-binding: t -*- + +;;; Commentary: + +;; Yes, I edit my init.el often enough I need to write a mode for it. + +;;; Code: + +(require '+lisp) + +;;; Sort `setup' forms + +(defun +init--sexp-setup-p (sexp-str &optional head) + "Is SEXP-STR a `setup' form, optionally with a HEAD form?" + (let ((head (if (and head (symbolp head)) + (symbol-name head) + head))) + (and (string-match-p (rx (: bos (* whitespace) "(setup")) sexp-str) + (if head + (string-match-p (concat "\\`.*" head) sexp-str) + t)))) + +(defun +init-sort () + "Sort init.el. +Sort based on the following heuristic: `setup' forms (the +majority of my init.el) are sorted after everything else, and +within that group, forms with a HEAD of `:require' are sorted +first, and `:straight' HEADs are sorted last. All other forms +are sorted lexigraphically." + (interactive) + (save-excursion + (save-restriction + (widen) + (+lisp-sort-sexps + (point-min) (point-max) + ;; Key function + nil + ;; Sort function + (lambda (s1 s2) + (let ((s1 (cdr s1)) (s2 (cdr s2))) + (cond + ;; Sort everything /not/ `setup' /before/ `setup' + ((and (+init--sexp-setup-p s1) + (not (+init--sexp-setup-p s2))) + nil) + ((and (+init--sexp-setup-p s2) + (not (+init--sexp-setup-p s1))) + t) + ;; otherwise... + (t (let ((s1-straight (+init--sexp-setup-p s1 :straight)) + (s2-straight (+init--sexp-setup-p s2 :straight)) + (s1-require (+init--sexp-setup-p s1 :require)) + (s2-require (+init--sexp-setup-p s2 :require))) + (cond + ;; `:straight' setups have extra processing + ((and s1-straight s2-straight) + (let* ((r (rx (: ":straight" (? "-when") (* space) (? "(")))) + (s1 (replace-regexp-in-string r "" s1)) + (s2 (replace-regexp-in-string r "" s2))) + (string< s1 s2))) + ;; `:require' setups go first + ((and s1-require (not s2-require)) t) + ((and s2-require (not s1-require)) nil) + ;; `:straight' setups go last + ((and s1-straight (not s2-straight)) nil) + ((and s2-straight (not s1-straight)) t) + ;; otherwise, sort lexigraphically + (t (string< s1 s2)))))))))))) + +;;; Add `setup' forms to `imenu-generic-expression' + +(defun +init-add-setup-to-imenu () + "Recognize `setup' forms in `imenu'." + ;; `imenu-generic-expression' automatically becomes buffer-local when set + (setf (alist-get "Setup" imenu-generic-expression nil nil 'string-equal) + (list + (rx (: bol (* space) + "(setup" (+ space) + (group (? "(") (* nonl)))) + 1))) + +;;; Major mode + +;;;###autoload +(define-derived-mode +init-mode emacs-lisp-mode "Init.el" + "`emacs-lisp-mode', but with a few specialized bits and bobs for init.el.") + +;;;###autoload +(add-to-list 'auto-mode-alist '("/init\\.el\\'" . +init-mode)) + +(provide '+init) +;;; +init.el ends here diff --git a/lisp/+lisp.el b/lisp/+lisp.el new file mode 100644 index 0000000..3267fd9 --- /dev/null +++ b/lisp/+lisp.el @@ -0,0 +1,71 @@ +;;; +lisp.el --- extra lisp functionality -*- lexical-binding: t -*- + +;;; Code: + +;;; Sort sexps in a region. +;; https://github.com/alphapapa/unpackaged.el + +(defun +lisp-skip-whitespace () + (while (looking-at (rx (1+ (or space "\n")))) + (goto-char (match-end 0)))) + +(defun +lisp-skip-both () + (while (cond ((or (nth 4 (syntax-ppss)) + (ignore-errors + (save-excursion + (forward-char 1) + (nth 4 (syntax-ppss))))) + (forward-line 1)) + ((looking-at (rx (1+ (or space "\n")))) + (goto-char (match-end 0)))))) + +(defun +lisp-sort-sexps (beg end &optional key-fn sort-fn) + "Sort sexps between BEG and END. +Comments stay with the code below. + +Optional argument KEY-FN will determine where in each sexp to +start sorting. e.g. (lambda (sexp) (symbol-name (car sexp))) + +Optional argument SORT-FN will determine how to sort two sexps' +strings. It's passed to `sort'. By default, it sorts the sexps +with `string<' starting with the key determined by KEY-FN." + (interactive "r") + (save-excursion + (save-restriction + (narrow-to-region beg end) + (goto-char beg) + (+lisp-skip-both) + (cl-destructuring-bind (sexps markers) + (cl-loop do (+lisp-skip-whitespace) + for start = (point-marker) + for sexp = (ignore-errors + (read (current-buffer))) + for end = (point-marker) + while sexp + ;; Collect the real string, then one used for sorting. + collect (cons (buffer-substring (marker-position start) + (marker-position end)) + (save-excursion + (goto-char (marker-position start)) + (+lisp-skip-both) + (if key-fn + (funcall key-fn sexp) + (buffer-substring + (point) + (marker-position end))))) + into sexps + collect (cons start end) + into markers + finally return (list sexps markers)) + (setq sexps (sort sexps (if sort-fn sort-fn + (lambda (a b) + (string< (cdr a) (cdr b)))))) + (cl-loop for (real . sort) in sexps + for (start . end) in markers + do (progn + (goto-char (marker-position start)) + (insert-before-markers real) + (delete-region (point) (marker-position end)))))))) + +(provide '+lisp) +;;; +lisp.el ends here diff --git a/lisp/+org.el b/lisp/+org.el new file mode 100644 index 0000000..a4ce230 --- /dev/null +++ b/lisp/+org.el @@ -0,0 +1,341 @@ +;;; +org.el -*- lexical-binding: t; -*- + +;;; Code: + +(require 'org) +(require 'org-element) +(require 'ox) + +;;; org-return-dwim - https://github.com/alphapapa/unpackaged.el +;; http://kitchingroup.cheme.cmu.edu/blog/2017/04/09/A-better-return-in-org-mode/ + +(defun +org-element-descendant-of (type element) + "Return non-nil if ELEMENT is a descendant of TYPE. +TYPE should be an element type, like `item' or `paragraph'. +ELEMENT should be a list like that returned by `org-element-context'." + ;; MAYBE: Use `org-element-lineage'. + (when-let* ((parent (org-element-property :parent element))) + (or (eq type (car parent)) + (+org-element-descendant-of type parent)))) + +(defun +org-return-dwim (&optional prefix) + "A helpful replacement for `org-return'. With PREFIX, call `org-return'. + +On headings, move point to position after entry content. In +lists, insert a new item or end the list, with checkbox if +appropriate. In tables, insert a new row or end the table." + (interactive "P") + ;; Auto-fill if enabled + (when auto-fill-function + (if (listp auto-fill-function) + (dolist (func auto-fill-function) + (funcall func)) + (funcall auto-fill-function))) + (if prefix + ;; Handle prefix args + (pcase prefix + ('(4) (newline)) + ('(16) (newline 2)) + ;; this is ... not ideal. but whatever. + (_ (newline prefix))) + (cond + ;; Act depending on context around point. + ((and org-return-follows-link + (eq 'link (car (org-element-context)))) + ;; Link: Open it. + (org-open-at-point-global)) + + ((org-at-heading-p) + ;; Heading: Move to position after entry content. + ;; NOTE: This is probably the most interesting feature of this function. + (let ((heading-start (org-entry-beginning-position))) + (goto-char (org-entry-end-position)) + (cond ((and (org-at-heading-p) + (= heading-start (org-entry-beginning-position))) + ;; Entry ends on its heading; add newline after + (end-of-line) + (insert "\n\n")) + (t + ;; Entry ends after its heading; back up + (forward-line -1) + (end-of-line) + (when (org-at-heading-p) + ;; At the same heading + (forward-line) + (insert "\n") + (forward-line -1)) + (while (not + (looking-back + (rx (repeat 3 (seq (optional blank) "\n"))) + nil)) + (insert "\n")) + (forward-line -1))))) + + ((org-at-item-checkbox-p) + ;; Checkbox: Insert new item with checkbox. + (org-insert-todo-heading nil)) + + ((org-in-item-p) + ;; Plain list + (let* ((context (org-element-context)) + (first-item-p (eq 'plain-list (car context))) + (itemp (eq 'item (car context))) + (emptyp (eq (org-element-property :contents-begin context) + (org-element-property :contents-end context))) + (item-child-p + (+org-element-descendant-of 'item context))) + ;; The original function from unpackaged just tested the (or ...) test + ;; in this cond, in an if. However, that doesn't auto-end nested + ;; lists. So I made this form a cond and added the (and...) test in + ;; the first position, which is clunky (the delete-region... stuff + ;; comes twice) and might not be needed. More testing, obviously, but + ;; for now, it works well enough. + (cond ((and itemp emptyp) + (delete-region (line-beginning-position) (line-end-position)) + (insert "\n\n")) + ((or first-item-p + (and itemp (not emptyp)) + item-child-p) + (org-insert-item)) + (t (delete-region (line-beginning-position) (line-end-position)) + (insert "\n"))))) + + ((when (fboundp 'org-inlinetask-in-task-p) + (org-inlinetask-in-task-p)) + ;; Inline task: Don't insert a new heading. + (org-return)) + + ((org-at-table-p) + (cond ((save-excursion + (beginning-of-line) + ;; See `org-table-next-field'. + (cl-loop with end = (line-end-position) + for cell = (org-element-table-cell-parser) + always (equal (org-element-property :contents-begin cell) + (org-element-property :contents-end cell)) + while (re-search-forward "|" end t))) + ;; Empty row: end the table. + (delete-region (line-beginning-position) (line-end-position)) + (org-return)) + (t + ;; Non-empty row: call `org-return'. + (org-return)))) + (t + ;; All other cases: call `org-return'. + (org-return))))) + +(defun +org-table-copy-down (n) + "Call `org-table-copy-down', or `org-return' outside of a table. +N is passed to the functions." + (interactive "p") + (if (org-table-check-inside-data-field 'noerror) + (org-table-copy-down n) + (+org-return-dwim n))) + +;;; org-fix-blank-lines - unpackaged.el + +(defun +org-fix-blank-lines (&optional prefix) + "Ensure blank lines around headings. +Optional PREFIX argument operates on the entire buffer. +Drawers are included with their headings." + (interactive "P") + (org-map-entries (lambda () + (org-with-wide-buffer + ;; `org-map-entries' narrows the buffer, which + ;; prevents us from seeing newlines before the + ;; current heading, so we do this part widened. + (while (not (looking-back "\n\n" nil)) + ;; Insert blank lines before heading. + (insert "\n"))) + (let ((end (org-entry-end-position))) + ;; Insert blank lines before entry content + (forward-line) + (while (and (org-at-planning-p) + (< (point) (point-max))) + ;; Skip planning lines + (forward-line)) + (while (re-search-forward + org-drawer-regexp end t) + ;; Skip drawers. You might think that + ;; `org-at-drawer-p' would suffice, but for + ;; some reason it doesn't work correctly when + ;; operating on hidden text. This works, taken + ;; from `org-agenda-get-some-entry-text'. + (re-search-forward "^[ \t]*:END:.*\n?" end t) + (goto-char (match-end 0))) + (unless (or (= (point) (point-max)) + (org-at-heading-p) + (looking-at-p "\n")) + (insert "\n")))) + t + (if prefix + nil + 'tree))) + +;;; org-count-words + +(defun +org-count-words-stupidly (start end &optional limit) + "Count words between START and END, ignoring a lot. + +Since this function is, for some reason, pricy, the optional +parameter LIMIT sets a word limit at which to stop counting. +Once the function hits that number, it'll return -LIMIT +instead of the true count." + (interactive (list nil nil)) + (cond ((not (called-interactively-p 'any)) + (let ((words 0) + (continue t)) + (save-excursion + (save-restriction + (narrow-to-region start end) + (goto-char (point-min)) + (while (and continue + (< (point) (point-max))) + (cond + ;; Ignore comments + ((or (org-at-comment-p) + (org-in-commented-heading-p)) + (forward-line)) + ;; Ignore headings + ((or (org-at-heading-p)) + (forward-line)) + ;; Ignore property and log drawers + ((or (looking-at org-drawer-regexp) + (looking-at org-clock-drawer-re)) + (search-forward ":END:" nil :noerror) + (forward-line)) + ;; Ignore DEADLINE and SCHEDULED keywords + ((or (looking-at org-deadline-regexp) + (looking-at org-scheduled-regexp) + (looking-at org-closed-time-regexp)) + (forward-line)) + ;; Ignore tables + ((org-at-table-p) (forward-line)) + ;; Ignore hyperlinks, but count the descriptions + ((looking-at org-link-bracket-re) + (when-let ((desc (match-string-no-properties 5))) + (save-match-data + (setq words (+ words + (length (remove "" + (org-split-string + desc "\\W"))))))) + (goto-char (match-end 0))) + ;; Ignore source blocks + ((org-in-src-block-p) (forward-line)) + ;; Ignore blank lines + ((looking-at "^$") + (forward-line)) + ;; Count everything else + (t + ;; ... unless it's in a few weird contexts + (let ((contexts (org-context))) + (cond ((or (assoc :todo-keyword contexts) + (assoc :priority contexts) + (assoc :keyword contexts) + (assoc :checkbox contexts)) + (forward-word-strictly)) + + (t (setq words (1+ words)) + (if (and limit + (> words limit)) + (setq words (- limit) + continue nil)) + (forward-word-strictly))))))))) + words)) + ((use-region-p) + (message "%d words in region" + (+org-count-words-stupidly (region-beginning) + (region-end)))) + (t + (message "%d words in buffer" + (+org-count-words-stupidly (point-min) + (point-max)))))) + +;;; org-insert-link-dwim - https://xenodium.com/emacs-dwim-do-what-i-mean/ + +(defun +org-insert-link-dwim () + "Like `org-insert-link' but with personal dwim preferences." + (interactive) + (let* ((point-in-link (org-in-regexp org-link-any-re 1)) + (clipboard-url (when (string-match-p + (rx (sequence bos + (or "http" + "gemini" + "gopher"))) + (current-kill 0)) + (current-kill 0))) + (region-content (when (region-active-p) + (buffer-substring-no-properties (region-beginning) + (region-end))))) + (cond ((and region-content clipboard-url (not point-in-link)) + (delete-region (region-beginning) (region-end)) + (insert (org-link-make-string clipboard-url region-content))) + ((and clipboard-url (not point-in-link)) + (insert (org-link-make-string + clipboard-url + (read-string "title: " + (with-current-buffer + (url-retrieve-synchronously + clipboard-url) + (dom-text + (car + (dom-by-tag (libxml-parse-html-region + (point-min) + (point-max)) + 'title)))))))) + (t + (call-interactively 'org-insert-link))))) + +;;; Navigate headings with widening + +(defun +org-next-heading-widen (arg) + "Find the ARGth next org heading, widening if necessary." + (interactive "p") + (let ((current-point (point)) + (point-target (if (> arg 0) (point-max) (point-min)))) + (org-next-visible-heading arg) + (when (and (buffer-narrowed-p) + (= (point) point-target) + (or (and (> arg 0)) + (and (< arg 0) + (= (point) current-point)))) + (widen) + (org-next-visible-heading arg)))) + +(defun +org-previous-heading-widen (arg) + "Find the ARGth previous org heading, widening if necessary." + (interactive "p") + (+org-next-heading-widen (- arg))) + +;;; Hooks & Advice + +(defun +org-before-save@prettify-buffer () + (save-mark-and-excursion + (mark-whole-buffer) + ;;(org-fill-paragraph nil t) + (+org-fix-blank-lines t) + (org-align-tags t))) + +(defun +org-delete-backward-char (N) + "Keep tables aligned while deleting N characters backward. +When deleting backwards, in tables this function will insert +whitespace in front of the next \"|\" separator, to keep the +table aligned. The table will still be marked for re-alignment +if the field did fill the entire column, because, in this case +the deletion might narrow the column." + (interactive "p") + (save-match-data + (org-check-before-invisible-edit 'delete-backward) + (if (and (= N 1) + (not overwrite-mode) + (not (org-region-active-p)) + (not (eq (char-before) ?|)) + (save-excursion (skip-chars-backward " \t") (not (bolp))) + (looking-at-p ".*?|") + (org-at-table-p)) + (progn (forward-char -1) (org-delete-char 1)) + (backward-delete-char-untabify N) + (org-fix-tags-on-the-fly)))) + +(provide '+org) +;;; +org.el ends here diff --git a/lisp/+setup.el b/lisp/+setup.el new file mode 100644 index 0000000..dce5d7b --- /dev/null +++ b/lisp/+setup.el @@ -0,0 +1,105 @@ +;;; +setup.el -- my `setup' commands -*- lexical-binding: t -*- + +;; Author: Case Duckworth + +;; This file is NOT part of GNU Emacs. + +;;; License: +;; Everyone is permitted to do whatever with this software, without +;; limitation. This software comes without any warranty whatsoever, +;; but with two pieces of advice: +;; - Don't hurt yourself. +;; - Make good choices. + +;;; Commentary: + +;; `setup', by Philip Kaludercic, is a wonderful package that works +;; sort of like `use-package', but to my mind it's cleaner and easier +;; to extend. These are my additions to the local macros provided by +;; the package. + +;;; Code: + +(require 'el-patch) +(require 'setup) +(require 'straight) + +;; I don't like the "magic" `setup' performs to ensure a symbol is a +;; function in `:global', `:bind', `:hook', `:hook-into', and others. +;; So here, I'll just make it return the symbol unmodified. +(el-patch-feature setup) +(with-eval-after-load 'setup + (el-patch-defvar + (el-patch-add setup-ensure-function-inhibit nil + "Whether to inhibit `setup-ensure-function'.")) + (el-patch-defun setup-ensure-function (sexp) + (el-patch-concat + "Attempt to return SEXP as a quoted function name." + (el-patch-add + "\nIf `setup-ensure-function-inhibit' is non-nil, just return SEXP.")) + (el-patch-wrap 3 0 + (if (and setup-ensure-function-inhibit + (not (eq sexp (setup-get 'mode)))) + sexp + (cond ((eq (car-safe sexp) 'function) + sexp) + ((eq (car-safe sexp) 'quote) + `#',(cadr sexp)) + ((symbolp sexp) + `#',sexp) + (sexp)))))) + +(setup-define :face + (lambda (face spec) + `(custom-set-faces '(,face ,spec 'now "Customized by `setup'."))) + :documentation "Customize FACE with SPEC using `custom-set-faces'." + :repeatable t) + +(setup-define :load-after + (lambda (&rest features) + (let ((body `(require ',(setup-get 'feature)))) + (dolist (feature (nreverse features)) + (setq body `(with-eval-after-load ',feature ,body))) + body)) + :documentation "Load the current feature after FEATURES.") + +(setup-define :also-straight + (lambda (recipe) `(setup (:straight ,recipe))) + :documentation + "Install RECIPE with `straight-use-package', after loading FEATURE." + :repeatable t + :after-loaded t) + +(setup-define :straight + (lambda (recipe) + `(unless (straight-use-package ',recipe) + ,(setup-quit))) + :documentation + "Install RECIPE with `straight-use-package'. +This macro can be used as HEAD, and will replace itself with the +first RECIPE's package." + :repeatable t + :shorthand (lambda (sexp) + (let ((recipe (cadr sexp))) + (if (consp recipe) + (car recipe) + recipe)))) + +(setup-define :straight-when + (lambda (recipe condition) + `(unless (and ,condition + (straight-use-package ',recipe)) + ,(setup-quit))) + :documentation + "Install RECIPE with `straight-use-package' when CONDITION is met. +If CONDITION is false, or if `straight-use-package' fails, stop +evaluating the body. This macro can be used as HEAD, and will +replace itself with the RECIPE's package." + :repeatable 2 + :indent 1 + :shorthand (lambda (sexp) + (let ((recipe (cadr sexp))) + (if (consp recipe) (car recipe) recipe)))) + +(provide '+setup) +;;; +setup.el ends here diff --git a/lisp/+util.el b/lisp/+util.el new file mode 100644 index 0000000..0870a71 --- /dev/null +++ b/lisp/+util.el @@ -0,0 +1,81 @@ +;;; +util.el --- utility whatevers -*- lexical-binding: t -*- + +;;; Commentary: + +;; This file is going to be my version of like, subr.el -- lots of +;; random shit that all goes in here. + +;;; Code: + +(require 'cl-lib) + +(defgroup +util nil + "Utility whatevers." + :group 'convenience) + +;;; STRINGS + +(defcustom +string-default-alignment 'left + "Default alignment." + :type '(choice (const :tag "Left" 'left) + (const :tag "Right" 'right))) + +;; stolen from s.el +(defun +string-repeat (n s) + "Make a string of S repeated N times." + (declare (pure t) + (side-effect-free t)) + (let (ss) + (while (> n 0) + (setq ss (cons s ss) + n (1- n))) + (apply 'concat ss))) + +(defun +string-truncate (s length &optional ellipsis alignment) + "Return S, shortened to LENGTH including ELLIPSIS and aligned to ALIGNMENT. + +ELLIPSIS defaults to \"...\". + +ALIGNMENT defaults to `+string-default-alignment'." + (declare (pure t) + (side-effect-free t)) + (let ((ellipsis (or ellipsis "...")) + (alignment (or alignment +string-default-alignment))) + (if (> (length s) length) + (format "%s%s" + (substring s 0 (- length (length ellipsis))) + ellipsis) + s))) + +(cl-defun +string-align (s len + &key + (before "") (after "") (fill " ") + (ellipsis "...") + (alignment +string-default-alignment)) + "Print S to fit in LEN characters. +Optional arguments BEFORE and AFTER specify strings to go on +either side of S. + +FILL is the string to fill extra space with (default \" \"). + +ELLIPSIS is the string to show when S is too long to fit (default \"...\"). + +ALIGNMENT can be one of these: +- nil: align to `+string-default-alignment' +- `left': align left +- `right': align right" + (let* ((s-length (length s)) + (before-length (length before)) + (after-length (length after)) + (max-length (- len (+ before-length after-length))) + (left-over (max 0 (- max-length s-length))) + (filler (+string-repeat left-over fill))) + (format "%s%s%s%s%s" + before + (if (eq alignment 'left) "" filler) + (+string-truncate s max-length ellipsis alignment) + (if (eq alignment 'right) "" filler) + after))) + +(provide '+util) +;;; +util.el ends here diff --git a/lisp/acdw-apheleia.el b/lisp/acdw-apheleia.el deleted file mode 100644 index 1b646ef..0000000 --- a/lisp/acdw-apheleia.el +++ /dev/null @@ -1,25 +0,0 @@ -;;; acdw-apheleia.el --- bespoke apheleia junk -*- lexical-binding: t -*- - -;;; Commentary: - -;;; Code: - -(require 'apheleia) - -(defcustom apheleia-stupid-modes '(makefile-mode - org-mode) - "List of stupid modes to not use `apheleia-global-mode' on." - :type '(repeat function) - :group 'apheleia) - -(defun apheleia-dumb-auto-format () - "Format a buffer dumbly." - ;; If there's no apheleia formatter for the mode, just indent the - ;; buffer. - (unless (or (apply #'derived-mode-p apheleia-stupid-modes) - (and (fboundp 'apheleia--get-formatter-command) - (apheleia--get-formatter-command))) - (indent-region (point-min) (point-max)))) - -(provide 'acdw-apheleia) -;;; acdw-apheleia ends here diff --git a/lisp/acdw-autoinsert.el b/lisp/acdw-autoinsert.el deleted file mode 100644 index bc0810a..0000000 --- a/lisp/acdw-autoinsert.el +++ /dev/null @@ -1,58 +0,0 @@ -;;; acdw-autoinsert.el --- autoinsert.el -*- lexical-binding: t; -*- - -;; Copyright (C) 2021 Case Duckworth - -;; Author: Case Duckworth ") - " ") - 'face 'circe-prompt-face - 'read-only t - 'intangible t - 'cursor-intangible t))) - -;;; Advices - -(defun circe-part@kill-buffer (&rest _) - "Advice to kill the channel buffer after PART." - (let ((circe-channel-killed-confirmation nil)) - (kill-buffer))) - -(defun circe-quit@kill-buffer (&rest _) - "Advice to kill all buffers of a server after QUIT." - ;; `circe-server-killed-confirmation' set to nil, and manually - ;; deleting all chat buffers, pending Github issue #402 - ;; (https://github.com/emacs-circe/circe/issues/402) - (let ((circe-server-killed-confirmation nil)) - (with-circe-server-buffer - (dolist (buf (circe-server-chat-buffers)) - (let ((circe-channel-killed-confirmation nil)) - (run-with-timer 0.1 nil #'kill-buffer buf))) - (run-with-timer 0.1 nil #'kill-buffer)))) - -(defun circe-gquit@kill-buffer (&rest _) - "Advice to kill all Circe related buffers after GQUIT." - ;; `circe-server-killed-confirmation' set to nil, and manually - ;; deleting all chat buffers, pending Github issue #402 - ;; (https://github.com/emacs-circe/circe/issues/402) - (let ((circe-server-killed-confirmation nil)) - (dolist (buf (circe-server-buffers)) - (with-current-buffer buf - (dolist (buf (circe-server-chat-buffers)) - (let ((circe-channel-killed-confirmation nil)) - (run-with-timer 0.1 nil #'kill-buffer buf))) - (run-with-timer 0.1 nil #'kill-buffer))))) - -;;; Patches - -(el-patch-feature circe) -(with-eval-after-load 'circe - (defvar circe-server-buffer-action 'pop-to-buffer-same-window - "What to do with `circe-server' buffers when created.") - - (el-patch-defun circe (network-or-server &rest server-options) - "Connect to IRC. - -Connect to the given network specified by NETWORK-OR-SERVER. - -When this function is called, it collects options from the -SERVER-OPTIONS argument, the user variable -`circe-network-options', and the defaults found in -`circe-network-defaults', in this order. - -If NETWORK-OR-SERVER is not found in any of these variables, the -argument is assumed to be the host name for the server, and all -relevant settings must be passed via SERVER-OPTIONS. - -All SERVER-OPTIONS are treated as variables by getting the string -\"circe-\" prepended to their name. This variable is then set -locally in the server buffer. - -See `circe-network-options' for a list of common options." - (interactive (circe--read-network-and-options)) - (let* ((options (circe--server-get-network-options network-or-server - server-options)) - (buffer (circe--server-generate-buffer options))) - (with-current-buffer buffer - (circe-server-mode) - (circe--server-set-variables options) - (circe-reconnect)) - (el-patch-swap (pop-to-buffer-same-window buffer) - (funcall circe-server-buffer-action buffer))))) - -;;; Dumb modes - -(define-minor-mode circe-cappy-hour-mode - "ENABLE CAPPY HOUR IN CIRCE!" - :lighter "CAPPY HOUR" - (when (derived-mode-p 'circe-chat-mode) - (if circe-cappy-hour-mode - (setq-local lui-input-function - (lambda (input) (circe--input (upcase input)))) - ;; XXX: It'd be better if this were more general, but whatever. - (setq-local lui-input-function #'circe--input)))) - -(provide 'acdw-circe) -;;; acdw-circe.el ends here diff --git a/lisp/acdw-compat.el b/lisp/acdw-compat.el deleted file mode 100644 index 3221191..0000000 --- a/lisp/acdw-compat.el +++ /dev/null @@ -1,555 +0,0 @@ -;;; acdw-compat.el -*- lexical-binding: t; coding: utf-8-unix -*- - -;; Author: Case Duckworth <(rot13-string "npqj@npqj.arg")> -;; Created: 2021-08-11 -;; Keywords: configuration -;; URL: https://tildegit.org/acdw/emacs - -;; This file is NOT part of GNU Emacs. - -;;; License: -;; Everyone is permitted to do whatever with this software, without -;; limitation. This software comes without any warranty whatsoever, -;; but with two pieces of advice: -;; - Don't hurt yourself. -;; - Make good choices. - -;;; Commentary: - -;; This file contains functions, variables, and other code that might not be in -;; every version of Emacs I use. - -;;; Code: - -;; Convenience macro -(defmacro safely (&rest defines) - "Wrap DEFINES in tests to make sure they're not already defined. -Is it necessary? Who knows!!" - (let (output) - (dolist (form defines) - ;; this is one part where elisp being a lisp-2 bites us... - (push (cond ((memq (car form) - '(;; makes functions - define-global-minor-mode - define-globalized-minor-mode - define-minor-mode - defmacro - defsubst - defun)) - `(unless (fboundp ',(cadr form)) - ,form)) - ((memq (car form) - '(;; makes variables - defcustom - defvar - defvar - defvar-local - defvar-mode-local - defvaralias)) - `(unless (boundp ',(cadr form)) - ,form)) - (t form)) - output)) - `(progn ,@(nreverse output)))) - - -;;; Functions for changing capitalization that Do What I Mean -;; Defined in EMACS/lisp/simple.el -(safely - (defun upcase-dwim (arg) - "Upcase words in the region, if active; if not, upcase word at point. -If the region is active, this function calls `upcase-region'. -Otherwise, it calls `upcase-word', with prefix argument passed to it -to upcase ARG words." - (interactive "*p") - (if (use-region-p) - (upcase-region (region-beginning) (region-end) (region-noncontiguous-p)) - (upcase-word arg))) - - (defun downcase-dwim (arg) - "Downcase words in the region, if active; if not, downcase word at point. -If the region is active, this function calls `downcase-region'. -Otherwise, it calls `downcase-word', with prefix argument passed to it -to downcase ARG words." - (interactive "*p") - (if (use-region-p) - (downcase-region (region-beginning) (region-end) (region-noncontiguous-p)) - (downcase-word arg))) - - (defun capitalize-dwim (arg) - "Capitalize words in the region, if active; if not, capitalize word at point. -If the region is active, this function calls `capitalize-region'. -Otherwise, it calls `capitalize-word', with prefix argument passed to it -to capitalize ARG words." - (interactive "*p") - (if (use-region-p) - (capitalize-region (region-beginning) (region-end) (region-noncontiguous-p)) - (capitalize-word arg)))) - - -;;; Repeat.el -;; Defined in EMACS/lisp/repeat.el - -(safely - (defcustom repeat-too-dangerous '(kill-this-buffer) - "Commands too dangerous to repeat with \\[repeat]." - :group 'convenience - :type '(repeat function)) - - (defvar repeat-message-function nil - "If non-nil, function used by `repeat' command to say what it's doing. -Message is something like \"Repeating command glorp\". -A value of `ignore' will disable such messages. To customize -display, assign a function that takes one string as an arg and -displays it however you want. -If this variable is nil, the normal `message' function will be -used to display the messages.") - - (defcustom repeat-on-final-keystroke t - "Allow `repeat' to re-execute for repeating lastchar of a key sequence. -If this variable is t, `repeat' determines what key sequence -it was invoked by, extracts the final character of that sequence, and -re-executes as many times as that final character is hit; so for example -if `repeat' is bound to C-x z, typing C-x z z z repeats the previous command -3 times. If this variable is a sequence of characters, then re-execution -only occurs if the final character by which `repeat' was invoked is a -member of that sequence. If this variable is nil, no re-execution occurs." - :group 'convenience - :type '(choice (const :tag "Repeat for all keys" t) - (const :tag "Don't repeat" nil) - (sexp :tag "Repeat for specific keys"))) - - (defvar repeat-num-input-keys-at-repeat -1 - "# key sequences read in Emacs session when `repeat' last invoked.") - - (defsubst repeat-is-really-this-command () - "Return t if this command is happening because user invoked `repeat'. -Usually, when a command is executing, the Emacs builtin variable -`this-command' identifies the command the user invoked. Some commands modify -that variable on the theory they're doing more good than harm; `repeat' does -that, and usually does do more good than harm. However, like all do-gooders, -sometimes `repeat' gets surprising results from its altruism. The value of -this function is always whether the value of `this-command' would've been -'repeat if `repeat' hadn't modified it." - (= repeat-num-input-keys-at-repeat num-input-keys)) - - (defvar repeat-previous-repeated-command nil - "The previous repeated command.") - - (defun repeat (repeat-arg) - "Repeat most recently executed command. -If REPEAT-ARG is non-nil (interactively, with a prefix argument), -supply a prefix argument to that command. Otherwise, give the -command the same prefix argument it was given before, if any. - -If this command is invoked by a multi-character key sequence, it -can then be repeated by repeating the final character of that -sequence. This behavior can be modified by the global variable -`repeat-on-final-keystroke'. - -`repeat' ignores commands bound to input events. Hence the term -\"most recently executed command\" shall be read as \"most -recently executed command not bound to an input event\"." - ;; The most recently executed command could be anything, so surprises could - ;; result if it were re-executed in a context where new dynamically - ;; localized variables were shadowing global variables in a `let' clause in - ;; here. (Remember that GNU Emacs 19 is dynamically localized.) - ;; To avoid that, I tried the `lexical-let' of the Common Lisp extensions, - ;; but that entails a very noticeable performance hit, so instead I use the - ;; "repeat-" prefix, reserved by this package, for *local* variables that - ;; might be visible to re-executed commands, including this function's arg. - (interactive "P") - (when (eq last-repeatable-command 'repeat) - (setq last-repeatable-command repeat-previous-repeated-command)) - (cond - ((null last-repeatable-command) - (error "There is nothing to repeat")) - ((eq last-repeatable-command 'mode-exit) - (error "last-repeatable-command is mode-exit & can't be repeated")) - ((memq last-repeatable-command repeat-too-dangerous) - (error "Command %S too dangerous to repeat automatically" - last-repeatable-command))) - (setq this-command last-repeatable-command - repeat-previous-repeated-command last-repeatable-command - repeat-num-input-keys-at-repeat num-input-keys) - (when (null repeat-arg) - (setq repeat-arg last-prefix-arg)) - ;; Now determine whether to loop on repeated taps of the final character - ;; of the key sequence that invoked repeat. The Emacs global - ;; last-command-event contains the final character now, but may not still - ;; contain it after the previous command is repeated, so the character - ;; needs to be saved. - (let ((repeat-repeat-char - (if (eq repeat-on-final-keystroke t) - last-command-event - ;; Allow only specified final keystrokes. - (car (memq last-command-event - (listify-key-sequence - repeat-on-final-keystroke)))))) - (if (eq last-repeatable-command (caar command-history)) - (let ((repeat-command (car command-history))) - (repeat-message "Repeating %S" repeat-command) - (eval repeat-command)) - (if (null repeat-arg) - (repeat-message "Repeating command %S" last-repeatable-command) - (setq current-prefix-arg repeat-arg) - (repeat-message - "Repeating command %S %S" repeat-arg last-repeatable-command)) - (when (eq last-repeatable-command 'self-insert-command) - ;; We used to use a much more complex code to try and figure out - ;; what key was used to run that self-insert-command: - ;; (if (<= (- num-input-keys - ;; repeat-num-input-keys-at-self-insert) - ;; 1) - ;; repeat-last-self-insert - ;; (let ((range (nth 1 buffer-undo-list))) - ;; (condition-case nil - ;; (setq repeat-last-self-insert - ;; (buffer-substring (car range) - ;; (cdr range))) - ;; (error (error "%s %s %s" ;Danger, Will Robinson! - ;; "repeat can't intuit what you" - ;; "inserted before auto-fill" - ;; "clobbered it, sorry"))))) - (setq last-command-event (char-before))) - (let ((indirect (indirect-function last-repeatable-command))) - (if (or (stringp indirect) - (vectorp indirect)) - ;; Bind last-repeatable-command so that executing the macro does - ;; not alter it. - (let ((last-repeatable-command last-repeatable-command)) - (execute-kbd-macro last-repeatable-command)) - (call-interactively last-repeatable-command)))) - (when repeat-repeat-char - (set-transient-map - (let ((map (make-sparse-keymap))) - (define-key map (vector repeat-repeat-char) - (if (null repeat-message-function) 'repeat - ;; If repeat-message-function is let-bound, preserve it for the - ;; next "iterations of the loop". - (let ((fun repeat-message-function)) - (lambda () - (interactive) - (let ((repeat-message-function fun)) - (setq this-command 'repeat) - ;; Beware: messing with `real-this-command' is *bad*, but we - ;; need it so `last-repeatable-command' can be recognized - ;; later (bug#12232). - (setq real-this-command 'repeat) - (call-interactively 'repeat)))))) - map))))) - - (defun repeat-message (format &rest args) - "Like `message' but displays with `repeat-message-function' if non-nil." - (let ((message (apply 'format format args))) - (if repeat-message-function - (funcall repeat-message-function message) - (message "%s" message)))) - - (defcustom repeat-exit-key nil - "Key that stops the modal repeating of keys in sequence. -For example, you can set it to like `isearch-exit'." - :type '(choice (const :tag "No special key to exit repeating sequence" nil) - (key-sequence :tag "Key that exits repeating sequence")) - :group 'convenience - :version "28.1") - - (defcustom repeat-exit-timeout nil - "Break the repetition chain of keys after specified timeout. -When a number, exit the repeat mode after idle time of the specified -number of seconds." - :type '(choice (const :tag "No timeout to exit repeating sequence" nil) - (number :tag "Timeout in seconds to exit repeating")) - :group 'convenience - :version "28.1") - - (defvar repeat-exit-timer nil - "Timer activated after the last key typed in the repeating key sequence.") - - (defcustom repeat-keep-prefix t - "Keep the prefix arg of the previous command." - :type 'boolean - :group 'convenience - :version "28.1") - - (defcustom repeat-echo-function #'repeat-echo-message - "Function to display a hint about available keys. -Function is called after every repeatable command with one argument: -a repeating map, or nil after deactivating the repeat mode." - :type '(choice (const :tag "Show hints in the echo area" - repeat-echo-message) - (const :tag "Show indicator in the mode line" - repeat-echo-mode-line) - (const :tag "No visual feedback" ignore) - (function :tag "Function")) - :group 'convenience - :version "28.1") - - (defvar repeat-in-progress nil - "Non-nil when the repeating map is active.") - - (defvar repeat-map nil - "The value of the repeating map for the next command. -A command called from the map can set it again to the same map when -the map can't be set on the command symbol property `repeat-map'.") - - (define-minor-mode repeat-mode - "Toggle Repeat mode. -When Repeat mode is enabled, and the command symbol has the property named -`repeat-map', this map is activated temporarily for the next command." - :global t :group 'convenience - (if (not repeat-mode) - (remove-hook 'post-command-hook 'repeat-post-hook) - (add-hook 'post-command-hook 'repeat-post-hook) - (let* ((keymaps nil) - (commands (all-completions - "" obarray (lambda (s) - (and (commandp s) - (get s 'repeat-map) - (push (get s 'repeat-map) keymaps)))))) - (message "Repeat mode is enabled for %d commands and %d keymaps; see `describe-repeat-maps'." - (length commands) - (length (delete-dups keymaps)))))) - - (defun repeat-post-hook () - "Function run after commands to set transient keymap for repeatable keys." - (let ((was-in-progress repeat-in-progress)) - (setq repeat-in-progress nil) - (when repeat-mode - (let ((rep-map (or repeat-map - (and (symbolp real-this-command) - (get real-this-command 'repeat-map))))) - (when rep-map - (when (boundp rep-map) - (setq rep-map (symbol-value rep-map))) - (let ((map (copy-keymap rep-map))) - - ;; Exit when the last char is not among repeatable keys, - ;; so e.g. `C-x u u' repeats undo, whereas `C-/ u' doesn't. - (when (and (zerop (minibuffer-depth)) ; avoid remapping in prompts - (or (lookup-key map (this-command-keys-vector)) - prefix-arg)) - - ;; Messaging - (unless prefix-arg - (funcall repeat-echo-function map)) - - ;; Adding an exit key - (when repeat-exit-key - (define-key map repeat-exit-key 'ignore)) - - (when (and repeat-keep-prefix (not prefix-arg)) - (setq prefix-arg current-prefix-arg)) - - (setq repeat-in-progress t) - (let ((exitfun (set-transient-map map))) - - (when repeat-exit-timer - (cancel-timer repeat-exit-timer) - (setq repeat-exit-timer nil)) - - (when repeat-exit-timeout - (setq repeat-exit-timer - (run-with-idle-timer - repeat-exit-timeout nil - (lambda () - (setq repeat-in-progress nil) - (funcall exitfun) - (funcall repeat-echo-function nil))))))))))) - - (setq repeat-map nil) - (when (and was-in-progress (not repeat-in-progress)) - (when repeat-exit-timer - (cancel-timer repeat-exit-timer) - (setq repeat-exit-timer nil)) - (funcall repeat-echo-function nil)))) - - (defun repeat-echo-message-string (keymap) - "Return a string with a list of repeating keys." - (let (keys) - (map-keymap (lambda (key _) (push key keys)) keymap) - (format-message "Repeat with %s%s" - (mapconcat (lambda (key) - (key-description (vector key))) - keys ", ") - (if repeat-exit-key - (format ", or exit with %s" - (key-description repeat-exit-key)) - "")))) - - (defun repeat-echo-message (keymap) - "Display available repeating keys in the echo area." - (if keymap - (let ((mess (repeat-echo-message-string keymap))) - (if (current-message) - (message "%s [%s]" (current-message) mess) - (message mess))) - (and (current-message) - (string-search "Repeat with " (current-message)) - (message nil)))) - - (defvar repeat-echo-mode-line-string - (propertize "[Repeating...] " 'face 'mode-line-emphasis) - "String displayed in the mode line in repeating mode.") - - (defun repeat-echo-mode-line (keymap) - "Display the repeat indicator in the mode line." - (if keymap - (unless (assq 'repeat-in-progress mode-line-modes) - (add-to-list 'mode-line-modes (list 'repeat-in-progress - repeat-echo-mode-line-string))) - (force-mode-line-update t))) - - (defun describe-repeat-maps () - "Describe mappings of commands repeatable by symbol property `repeat-map'." - (interactive) - (help-setup-xref (list #'describe-repeat-maps) - (called-interactively-p 'interactive)) - (let ((keymaps nil)) - (all-completions - "" obarray (lambda (s) - (and (commandp s) - (get s 'repeat-map) - (push s (alist-get (get s 'repeat-map) keymaps))))) - (with-help-window (help-buffer) - (with-current-buffer standard-output - (princ "A list of keymaps used by commands with the symbol property `repeat-map'.\n\n") - - (dolist (keymap (sort keymaps (lambda (a b) (string-lessp (car a) (car b))))) - (princ (format-message "`%s' keymap is repeatable by these commands:\n" - (car keymap))) - (dolist (command (sort (cdr keymap) 'string-lessp)) - (princ (format-message " `%s'\n" command))) - (princ "\n")))))) - -;;; Bindings! - (defvar undo-repeat-map - (let ((map (make-sparse-keymap))) - (define-key map "u" 'undo) - map) - "Keymap to repeat undo key sequences `C-x u u'. Used in `repeat-mode'.") - (put 'undo 'repeat-map 'undo-repeat-map) - - (defvar next-error-repeat-map - (let ((map (make-sparse-keymap))) - (define-key map "n" 'next-error) - (define-key map "\M-n" 'next-error) - (define-key map "p" 'previous-error) - (define-key map "\M-p" 'previous-error) - map) - "Keymap to repeat next-error key sequences. Used in `repeat-mode'.") - (put 'next-error 'repeat-map 'next-error-repeat-map) - (put 'previous-error 'repeat-map 'next-error-repeat-map) - - (defvar page-navigation-repeat-map - (let ((map (make-sparse-keymap))) - (define-key map "]" #'forward-page) - (define-key map "[" #'backward-page) - map) - "Keymap to repeat page navigation key sequences. Used in `repeat-mode'.") - (put 'forward-page 'repeat-map 'page-navigation-repeat-map) - (put 'backward-page 'repeat-map 'page-navigation-repeat-map) - - (defvar tab-bar-switch-repeat-map - (let ((map (make-sparse-keymap))) - (define-key map "o" 'tab-next) - (define-key map "O" 'tab-previous) - map) - "Keymap to repeat tab switch key sequences `C-x t o o O'. -Used in `repeat-mode'.") - (put 'tab-next 'repeat-map 'tab-bar-switch-repeat-map) - (put 'tab-previous 'repeat-map 'tab-bar-switch-repeat-map) - - (defvar tab-bar-move-repeat-map - (let ((map (make-sparse-keymap))) - (define-key map "m" 'tab-move) - (define-key map "M" (lambda () - (interactive) - (setq repeat-map 'tab-bar-move-repeat-map) - (tab-move -1))) - map) - "Keymap to repeat tab move key sequences `C-x t m m M'. -Used in `repeat-mode'.") - (put 'tab-move 'repeat-map 'tab-bar-move-repeat-map) - - (defvar other-window-repeat-map - (let ((map (make-sparse-keymap))) - (define-key map "o" 'other-window) - (define-key map "O" (lambda () - (interactive) - (setq repeat-map 'other-window-repeat-map) - (other-window -1))) - map) - "Keymap to repeat other-window key sequences. Used in `repeat-mode'.") - (put 'other-window 'repeat-map 'other-window-repeat-map) - - (defvar resize-window-repeat-map - (let ((map (make-sparse-keymap))) - ;; Standard keys: - (define-key map "^" 'enlarge-window) - (define-key map "}" 'enlarge-window-horizontally) - (define-key map "{" 'shrink-window-horizontally) - ;; Additional keys: - (define-key map "v" 'shrink-window) - map) - "Keymap to repeat window resizing commands. Used in `repeat-mode'.") - (put 'enlarge-window 'repeat-map 'resize-window-repeat-map) - (put 'enlarge-window-horizontally 'repeat-map 'resize-window-repeat-map) - (put 'shrink-window-horizontally 'repeat-map 'resize-window-repeat-map) - (put 'shrink-window 'repeat-map 'resize-window-repeat-map) - - (defvar outline-navigation-repeat-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-b") #'outline-backward-same-level) - (define-key map (kbd "b") #'outline-backward-same-level) - (define-key map (kbd "C-f") #'outline-forward-same-level) - (define-key map (kbd "f") #'outline-forward-same-level) - (define-key map (kbd "C-n") #'outline-next-visible-heading) - (define-key map (kbd "n") #'outline-next-visible-heading) - (define-key map (kbd "C-p") #'outline-previous-visible-heading) - (define-key map (kbd "p") #'outline-previous-visible-heading) - (define-key map (kbd "C-u") #'outline-up-heading) - (define-key map (kbd "u") #'outline-up-heading) - map)) - - (defvar outline-editing-repeat-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-v") #'outline-move-subtree-down) - (define-key map (kbd "v") #'outline-move-subtree-down) - (define-key map (kbd "C-^") #'outline-move-subtree-up) - (define-key map (kbd "^") #'outline-move-subtree-up) - (define-key map (kbd "C->") #'outline-demote) - (define-key map (kbd ">") #'outline-demote) - (define-key map (kbd "C-<") #'outline-promote) - (define-key map (kbd "<") #'outline-promote) - map)) - - (with-eval-after-load 'outline - (dolist (command '(outline-backward-same-level - outline-forward-same-level - outline-next-visible-heading - outline-previous-visible-heading - outline-up-heading)) - (put command 'repeat-map 'outline-navigation-repeat-map)) - - (dolist (command '(outline-move-subtree-down - outline-move-subtree-up - outline-demote - outline-promote)) - (put command 'repeat-map 'outline-editing-repeat-map)))) - - -;;; goto-address-mode -(safely - (defvar global-address-mode nil) - - (define-globalized-minor-mode global-goto-address-mode - goto-address-mode goto-addr-mode--turn-on - :version "28.1") - - (defun goto-addr-mode--turn-on () - (when (not goto-address-mode) - (goto-address-mode 1)))) - -(provide 'acdw-compat) -;;; acdw-compat.el ends here diff --git a/lisp/acdw-consult.el b/lisp/acdw-consult.el deleted file mode 100644 index 84a7fea..0000000 --- a/lisp/acdw-consult.el +++ /dev/null @@ -1,93 +0,0 @@ -;;; acdw-consult.el -*- lexical-binding: t; coding: utf-8-unix -*- - -;; Customization for consult. - -(require 'consult) - -(defun acdw-consult/sensible-grep (&optional arg) - "Perform `consult-git-grep' if in a git project, otherwise `consult-ripgrep' -if ripgrep is installed, otherwise `consult-grep'." - (interactive "P") - (call-interactively - (cond ((executable-find "rg") - (if (fboundp 'affe-grep) - #'affe-grep - #'consult-ripgrep)) - ((string-equal (vc-backend buffer-file-name) "Git") - #'consult-git-grep) - (t #'consult-grep)))) - -(defun acdw-consult/sensible-find (&optional arg) - "Peform `consult-locate' if locate is installed, otehrwise `consult-find'." - (interactive "P") - (call-interactively - (cond ((executable-find "locate") - #'consult-locate) - ((fboundp 'affe-find) - (when (executable-find "fd") - (setq affe-find-command "fd -HI -t f")) - #'affe-find) - (t #'consult-find)))) - -;; Orderless Regexp Compiler! -- from Consult Wiki -(defun consult--orderless-regexp-compiler (input type) - (setq input (orderless-pattern-compiler input)) - (cons - (mapcar (lambda (r) (consult--convert-regexp r type)) input) - (lambda (str) (orderless--highlight input str)))) - -(defun acdw-consult/complete-in-region (&rest args) - (apply (if vertico-mode - #'consult-completion-in-region - #'completion--in-region) - args)) - -(defmacro consult-history-to-modes (map-hook-alist) - (let (defuns) - (dolist (map-hook map-hook-alist) - (let ((map-name (symbol-name (car map-hook))) - (key-defs `(progn (define-key - ,(car map-hook) - (kbd "M-r") - (function consult-history)) - (define-key ,(car map-hook) - (kbd "M-s") nil)))) - (push (if (cdr map-hook) - `(add-hook ',(cdr map-hook) - (defun - ,(intern (concat map-name - "@consult-history-bind")) - nil - ,(concat - "Bind `consult-history' to M-r in " - map-name ".\n" - "Defined by `consult-history-to-modes'.") - ,key-defs)) - key-defs) - defuns))) - `(progn ,@ (nreverse defuns)))) - -;;; Circe buffers source - -(require 'cl-lib) -(autoload 'circe-server-buffers "circe") -(autoload 'circe-server-chat-buffers "circe") - -(defun circe-all-buffers () - (cl-loop with servers = (circe-server-buffers) - for server in servers - collect server - nconc - (with-current-buffer server - (cl-loop for buf in (circe-server-chat-buffers) - collect buf)))) - -(defvar circe-buffer-source - `(:name "circe" - :hidden t - :narrow ?c - :category buffer - :state ,#'consult--buffer-state - :items ,(lambda () (mapcar #'buffer-name (circe-all-buffers))))) - -(provide 'acdw-consult) diff --git a/lisp/acdw-cus-edit.el b/lisp/acdw-cus-edit.el deleted file mode 100644 index 89273f0..0000000 --- a/lisp/acdw-cus-edit.el +++ /dev/null @@ -1,32 +0,0 @@ -;;; acdw-cus-edit.el -*- lexical-binding: t -*- - -(defun acdw-cus/expand-widgets (&rest _) - "Expand descriptions in `Custom-mode' buffers." - (interactive) - ;; "More/Hide" widgets (thanks alphapapa!) - (widget-map-buttons (lambda (widget _) - (pcase (widget-get widget :off) - ("More" (widget-apply-action widget))) - nil)) - ;; "Show Value" widgets (the little triangles) - (widget-map-buttons (lambda (widget _) - (pcase (widget-get widget :off) - ("Show Value" - (widget-apply-action widget))) - nil))) - -(defvar acdw-cus/imenu-generic-expression ; thanks u/oantolin! - '(("Faces" (rx (seq bol - (or "Show" "Hide") " " - (group (zero-or-more nonl)) - " face: [sample]")) - 1) - ("Variables" (rx (seq bol - (or "Show Value" "Hide") " " - (group (zero-or-more - (not (any "\n:")))))) - 1)) - "Show faces and variables in `imenu'.") - -(provide 'acdw-cus-edit) -;;; acdw-cus-edit.el ends here diff --git a/lisp/acdw-erc.el b/lisp/acdw-erc.el deleted file mode 100644 index beea24b..0000000 --- a/lisp/acdw-erc.el +++ /dev/null @@ -1,228 +0,0 @@ -;;; acdw-erc.el -*- lexical-binding: t; coding: utf-8-unix -*- - -;; Author: Case Duckworth <(rot13-string "npqj@npqj.arg")> -;; Created: 24 May 2021 -;; Keywords: configuration -;; URL: https://tildegit.org/acdw/emacs - -;; This file is NOT part of GNU Emacs. - -;;; License: -;; Everyone is permitted to do whatever with this software, without -;; limitation. This software comes without any warranty whatsoever, -;; but with two pieces of advice: -;; - Don't hurt yourself. -;; - Make good choices. - -;;; Commentary: -;; `acdw-erc' is a dumping ground for functions and stuff for ERC, so they -;; don't clutter up `init.el'. - -;;; Code: - -(defgroup acdw-erc nil - "Customizations for ERC." - :group 'erc) - - -;;; Show a different header-line face when ERC is disconnected. -;; https://www.emacswiki.org/emacs/ErcModeline#h5o-1 - -(defface erc/header-line-disconnected - '((t (:foreground "black" :background "indianred"))) - "Face to use when ERC has been disconnected.") - -(defun erc/update-header-line-show-disconnected () - "Use a different face in the header-line when disconnected." - (erc-with-server-buffer - (cond ((erc-server-process-alive) 'erc-header-line) - (t 'erc/header-line-disconnected)))) - - -;;; Convenience functions -;; from Prelude: -;; https://github.com/bbatsov/prelude/blob/master/modules/prelude-erc.el#L114 - -(defcustom erc/servers nil - "The list of IRC servers to connect to with `erc/connect'." - :type '(list string)) - -(defcustom erc/bye-message "See You Space Cowpokes." - "Quit message sent when calling `erc/disconnect'." - :type 'string) - -(defun connect-to-erc (server &optional use-tls port nick) - "Connects to IRC SERVER at PORT with NICK. -If USE-TLS is non-nil, use TLS." - (let* ((use-tls (or use-tls t)) - (erc-fn (if use-tls #'erc-tls #'erc)) - (port (or port (if use-tls 6697 6667))) - (nick (or nick erc-nick))) - (funcall erc-fn - :server server - :port port - :nick nick))) - -(defun erc/connect () - "Connect to all the servers in `erc/servers'." - (interactive) - (require 'erc) - (mapcar #'connect-to-erc erc/servers)) - -(defun filter-server-buffers () - (delq nil (mapcar (lambda (x) - (and (erc-server-buffer-p x) x)) - (buffer-list)))) - -(defun erc/reconnect () - "Reconnect to all IRC servers." - (interactive) - (dolist (buffer (filter-server-buffers)) - (with-current-buffer buffer - (ignore-errors - (erc-cmd-RECONNECT))))) - -(defun erc/disconnect () - "Disconnect from all IRC servers." - (interactive) - (dolist (buffer (filter-server-buffers)) - (with-message (format "Killing server buffer: %s" (buffer-name buffer)) - (with-current-buffer buffer - (erc-quit-server erc/bye-message)))) - ;; TODO: kill all channel buffers - (force-mode-line-update)) - -(defun acdw-erc/prompt () - "The prompt to show for ERC." - ;; Rewrite s-truncate to avoid dependency. - (let ((name (buffer-name)) - (ellipsis "~") - (len erc-fill-static-center)) - (if (and len (> (length name) (- len 2))) - (format "%s%s>" - (substring name 0 (- len 2 (length ellipsis))) - ellipsis) - (propertize - (format "%s%s>" - name - (let ((ss) ; Rewrite s-repeat to avoid dependency. - (num (- len 2 (length name)))) - (while (> num 0) - (setq ss (cons " " ss)) - (setq num (1- num))) - (apply #'concat ss))) - 'read-only t - 'intangible t - 'cursor-intangible t)))) - -(defcustom erc-nick-truncate nil - "The width at which to truncate a nick with `erc-format-truncate-@nick'." - :group 'erc - :type 'integer) - -(defalias 'erc-propertize 'propertize) ; I guess...taken out in 28 ? - -(defun erc-format-truncate-@nick (&optional user channel-data) - "Format the nickname of USER as in `erc-format-@nick', with truncation. -Truncation is customized using the `erc-nick-truncate' variable. -See also `erc-format-nick-function'." - (when user - (let* ((nick (erc-server-user-nickname user)) - (prefix (erc-get-user-mode-prefix nick)) - (ellipsis "~") - (max-len (- erc-nick-truncate 2 ; one each for < and > - (length ellipsis) - (length prefix)))) - (concat (erc-propertize - prefix - 'font-lock-face 'erc-nick-prefix-face) - (if (and max-len (> (length nick) max-len)) - (format "%s%s" (substring nick 0 max-len) - ellipsis) - nick))))) - - -;;; Uh - -(defun acdw-erc/erc-switch-to-buffer (&optional arg) - "Prompt for ERC buffer to switch to. -Reverse prefix argument from `erc-switch-to-buffer'." - (interactive "P") - (erc-switch-to-buffer (not arg))) - - -;;; ERC-Bar -;; NEEDS MUCH WORK - -(defun erc-bar-move-back (n) - "Moves back n message lines. Ignores wrapping, and server messages." - (interactive "nHow many lines ? ") - (re-search-backward "^.*<.*>" nil t n)) - -(defun erc-bar-update-overlay () - "Update the overlay for current buffer, based on the content of -erc-modified-channels-alist. Should be executed on window change." - (interactive) - (let* ((info (assq (current-buffer) erc-modified-channels-alist)) - (count (cadr info))) - (if (and info (> count erc-bar-threshold)) - (save-excursion - (end-of-buffer) - (when (erc-bar-move-back count) - (let ((inhibit-field-text-motion t)) - (move-overlay erc-bar-overlay - (line-beginning-position) - (line-end-position) - (current-buffer))))) - (delete-overlay erc-bar-overlay)))) - -(defvar erc-bar-threshold 0 - "Display bar when there are more than erc-bar-threshold unread messages.") - -(defvar erc-bar-overlay nil - "Overlay used to set bar") - -(setq erc-bar-overlay (make-overlay 0 0)) -(overlay-put erc-bar-overlay 'face '(:overline "gray")) - -(with-eval-after-load 'erc-track - ;;put the hook before erc-modified-channels-update - (defadvice erc-track-mode (after erc-bar-setup-hook - (&rest args) activate) - (add-hook 'window-configuration-change-hook 'erc-bar-update-overlay -90)) - - (add-hook 'erc-send-completed-hook (lambda (str) - (erc-bar-update-overlay)))) - - -;;; ZNC babeee -;; needed variables are stored in private.el -(defun znc/connect (znc-server znc-port znc-nick irc-servers) - (interactive (let ((zserv (or znc/server - (read-string "ZNC Server: "))) - (zport (or znc/port - (read-number "ZNC Port: "))) - (znick (or znc/nick - (read-string "ZNC Nick: "))) - (servers (or znc/irc-servers - (list - (cons - (read-string "IRC Server to connect to: ") - (read-passwd "Password: ")))))) - (list zserv zport znick servers))) - (let ((si 0)) - (dolist (server irc-servers) - (run-at-time si nil - (lambda () - (erc-tls :server znc-server - :port znc-port - :nick znc-nick - :password (format "%s/%s:%s" - znc-nick - (car server) - (cdr server))))) - (setq si (1+ si))))) - - -(provide 'acdw-erc) -;;; acdw-erc.el ends here diff --git a/lisp/acdw-eshell.el b/lisp/acdw-eshell.el deleted file mode 100644 index eedcc8b..0000000 --- a/lisp/acdw-eshell.el +++ /dev/null @@ -1,93 +0,0 @@ -;;; acdw-eshell.el -*- lexical-binding: t; coding: utf-8-unix -*- - -;; Author: Case Duckworth <(rot13-string "npqj@npqj.arg")> -;; Keywords: configuration -;; URL: https://tildegit.org/acdw/emacs - -;; This file is NOT part of GNU Emacs. - -;;; License: -;; Everyone is permitted to do whatever with this software, without -;; limitation. This software comes without any warranty whatsoever, -;; but with two pieces of advice: -;; - Don't hurt yourself. -;; - Make good choices. - -;;; Commentary: - -;;; Code: - -(require 'cl-lib) - - -;;; Eshell starting and quitting - -(defun eshell-quit-or-delete-char (arg) - "Delete the character to the right, or quit eshell on an empty line." - (interactive "p") - (if (and (eolp) (looking-back eshell-prompt-regexp)) - (eshell-life-is-too-much) - (delete-forward-char arg))) - -;;;###autoload -(defun eshell-pop-or-quit (&optional buffer-name) - "Pop open an eshell buffer, or if in an eshell buffer, bury it." - (interactive) - (if (eq (current-buffer) (get-buffer (or buffer-name "*eshell*"))) - (eshell-life-is-too-much) - (with-message "Starting eshell" - (eshell)))) - - -;;; Insert previous arguments -;; Record arguments - -(defvar eshell-arg-history nil) -(defvar eshell-arg-history-index nil) -(add-to-list 'savehist-additional-variables 'eshell-arg-history) - -(defun eshell-record-args (&rest _) - "Record unique arguments onto the front of `eshell-arg-history'." - (setq eshell-arg-history - (cl-loop with history = eshell-arg-history - for arg in (reverse eshell-last-arguments) - do (setq history (cons arg (remove arg history))) - finally return history))) - -(defun eshell-insert-prev-arg () - "Insert an argument from `eshell-arg-history' at point." - (interactive) - (if (eq last-command 'eshell-insert-prev-arg) - (progn - (let ((pos (point))) - (eshell-backward-argument 1) - (delete-region (point) pos)) - (if-let ((text (nth eshell-arg-history-index - eshell-arg-history))) - (progn - (insert text) - (cl-incf eshell-arg-history-index)) - (insert (cl-first eshell-arg-history)) - (setq eshell-arg-history-index 1))) - (insert (cl-first eshell-arg-history)) - (setq eshell-arg-history-index 1))) - -(add-hook 'eshell-mode-hook - (lambda () - (add-hook 'eshell-post-command-hook - #'eshell-record-args nil t) - (local-set-key (kbd "M-.") #'eshell-insert-prev-arg))) - -;;;###autoload -(define-minor-mode eshell-arg-hist-mode - "Minor mode to enable argument history, like bash/zsh with M-." - :lighter "$." - :keymap (let ((map (make-sparse-keymap))) - (define-key map (kbd "M-.") #'eshell-insert-prev-arg) - map) - (if eshell-arg-hist-mode - (add-hook 'eshell-post-command-hook #'eshell-record-args nil t) - (remove-hook 'eshell-post-command-hook #'eshell-record-args t))) - -(provide 'acdw-eshell) -;;; acdw-eshell.el ends here diff --git a/lisp/acdw-eww.el b/lisp/acdw-eww.el deleted file mode 100644 index 8e7f42d..0000000 --- a/lisp/acdw-eww.el +++ /dev/null @@ -1,38 +0,0 @@ -;;; acdw-eww.el --- EWW customizations -*- lexical-binding: t -*- - -(require 'bookmark) -(require 'eww) - -(defun bookmark-eww--make () - "Make eww bookmark record." - `((filename . ,(plist-get eww-data :url)) - (title . ,(plist-get eww-data :title)) - (time . ,(current-time-string)) - (handler . ,#'bookmark-eww-handler) - (defaults . (,(concat - ;; url without the https and path - (replace-regexp-in-string - "/.*" "" - (replace-regexp-in-string - "\\`https?://" "" - (plist-get eww-data :url))) - " - " - ;; page title - (replace-regexp-in-string - "\\` +\\| +\\'" "" - (replace-regexp-in-string - "[\n\t\r ]+" " " - (plist-get eww-data :title)))))))) - - - -(defun bookmark-eww-handler (bm) - "Handler for eww bookmarks." - (eww-browse-url (alist-get 'filename bm))) - -(defun bookmark-eww--setup () - "Setup eww bookmark integration." - (setq-local bookmark-make-record-function #'bookmark-eww--make)) - -(provide 'acdw-eww) -;;; acdw-eww.el ends here diff --git a/lisp/acdw-fonts.el b/lisp/acdw-fonts.el deleted file mode 100644 index 0fce172..0000000 --- a/lisp/acdw-fonts.el +++ /dev/null @@ -1,176 +0,0 @@ -;;; acdw-fonts.el -- font setup -*- lexical-binding: t; coding: utf-8-unix -*- - -;; Author: Case Duckworth <(rot13-string "npqj@npqj.arg")> -;; Created: Sometime during Covid-19, 2020 -;; Keywords: configuration -;; URL: https://tildegit.org/acdw/emacs - -;; This file is NOT part of GNU Emacs. - -;; Everyone is permitted to do whatever with this software, without -;; limitation. This software comes without any warranty whatsoever, -;; but with two pieces of advice: -;; - Don't hurt yourself. -;; - Make good choices. - -;;; Commentary: -;; This code is based heavily on (and in fact, until I am able to tweak it, -;; will be a copy of) Oliver Taylor's code, available here: -;; https://github.com/olivertaylor/olivertaylor.github.io -;; /blob/master/notes/20210324_emacs-optical-font-adjustment.org - -;;; Code: - - -;; Variables - -(defvar acdw-fonts/monospace nil - "Monospace font to be used for `default' and `fixed-pitch' faces.") - -(defvar acdw-fonts/variable nil - "Variable font to be used for the `variable-pitch' face.") - -(defvar acdw-fonts/monospace-size 11 - "Font size, an integer, to be used for the `default' and `fixed-pitch' faces. - -This value is multiplied by 10, so 12 becomes 120, in order to -comply with Emacs's `set-face-attribute' requirements.") - -(defvar acdw-fonts/variable-size 12 - "Font size, an integer, to be used for the `variable-pitch' face. - -This value will be used to determine a relative (float) size -based on the default size. So if your default size is 12 and -your variable size is 14, the computed relative size will be -1.16.") - - -;; Functions - -(defun acdw-fonts/set () - "Set fonts according to `acdw-fonts' variables." - (interactive) - (set-face-attribute 'default nil - :family acdw-fonts/monospace - :height (* acdw-fonts/monospace-size 10)) - (set-face-attribute 'fixed-pitch nil - :family acdw-fonts/monospace - :height 1.0) - (set-face-attribute 'variable-pitch nil - :family acdw-fonts/variable - :height 1.0)) - - -;;; Larger Variable Pitch Mode - - -;; A minor mode to scale the variable-pitch face up to the height defined in -;; `acdw-fonts/variable-size' and the fixed-pitch face down to the height -;; defined in `acdw-fonts/monospace-size', buffer locally. This mode should -;; be enabled wherever you want to adjust face sizes, perhaps with a hook. - -(make-variable-buffer-local - (defvar larger-variable-pitch-mode-status nil - "Status of the larger-variable-pitch-mode")) - -(make-variable-buffer-local - (defvar variable-pitch-remapping nil - "variable-pitch remapping cookie for larger-variable-pitch-mode.")) - -(make-variable-buffer-local - (defvar fixed-pitch-remapping nil - "fixed-pitch remapping cookie for larger-variable-pitch-mode")) - -(defun larger-variable-pitch-mode-toggle () - (setq larger-variable-pitch-mode-status - (not larger-variable-pitch-mode-status)) - (if larger-variable-pitch-mode-status - (progn - (setq variable-pitch-remapping - (face-remap-add-relative - 'variable-pitch :height (/ (float acdw-fonts/variable-size) - (float acdw-fonts/monospace-size)))) - (setq fixed-pitch-remapping - (face-remap-add-relative - 'fixed-pitch :height (/ (float acdw-fonts/monospace-size) - (float acdw-fonts/variable-size)))) - (force-window-update (current-buffer))) - (progn - (face-remap-remove-relative variable-pitch-remapping) - (face-remap-remove-relative fixed-pitch-remapping)))) - -(define-minor-mode larger-variable-pitch-mode - "Minor mode to scale the variable- and fixed-pitch faces up and down." - :init-value nil - :lighter " V+" - (larger-variable-pitch-mode-toggle)) - -(defun acdw-fonts/buffer-face-hook () - "Activate and deactivate larger-variable-pitch-mode minor mode." - (if buffer-face-mode - (larger-variable-pitch-mode 1) - (larger-variable-pitch-mode -1))) - -(add-hook 'buffer-face-mode-hook #'acdw-fonts/buffer-face-hook) - - -;;; Emoji fonts -;; from https://old.reddit.com/r/emacs/comments/mvlid5/ - -(defun acdw-fonts/setup-emoji-fonts (&rest emoji-fonts) - "For all EMOJI-FONTS that exist, add them to the symbol fontset. - -This is for emoji fonts." - (let ((ffl (font-family-list))) - (dolist (font emoji-fonts) - (when (member font ffl) - (set-fontset-font t 'symbol - (font-spec :family font) nil 'append))))) - - -;;; Variable-pitch -;; from https://github.com/turbana/emacs-config#variable-pitch - -(defcustom acdw-fonts/fixed-pitch-faces '(linum - org-block - org-block-begin-line - org-block-end-line - org-checkbox - org-code - org-date - org-document-info-keyword - org-hide - org-indent - org-link - org-meta-line - org-special-keyword - org-table - whitespace-space) - "Faces to keep fixed-pitch in `acdw/variable-pitch-mode'." - :type 'sexp - :group 'faces) - -(defun acdw-fonts//variable-pitch-add-inherit (attrs parent) - "Add `:inherit PARENT' to ATTRS unless already present. -Handles cases where `:inherit' is already specified." - (let ((current-parent (plist-get attrs :inherit))) - (unless (or (eq parent current-parent) - (and (listp current-parent) - (member parent current-parent))) - (plist-put attrs :inherit (if current-parent - (list current-parent parent) - parent))))) - -(defun acdw-fonts/adapt-variable-pitch () - "Adapt `variable-pitch-mode' to keep some fonts fixed-pitch." - (when variable-pitch-mode - (mapc (lambda (face) - (when (facep face) - (apply #'set-face-attribute - face nil (acdw-fonts//variable-pitch-add-inherit - (face-attr-construct face) - 'fixed-pitch)))) - acdw-fonts/fixed-pitch-faces))) - -(provide 'acdw-fonts) -;;; acdw-fonts.el ends here diff --git a/lisp/acdw-frame.el b/lisp/acdw-frame.el deleted file mode 100644 index 753fd14..0000000 --- a/lisp/acdw-frame.el +++ /dev/null @@ -1,36 +0,0 @@ -;;; acdw-frame.el -*- lexical-binding: t; coding: utf-8-unix -*- - -;;; Fonts - -(defun acdw/set-first-face-attribute (face font-list) - "Set FACE to the first font found in FONT-LIST. -FONT-LIST is a list of `font-spec' plists to be passed to -`set-face-attribute'." - (cond - ((or (null window-system) - (null font-list)) - nil) - ((x-list-fonts (or (plist-get (car font-list) :font) - (plist-get (car font-list) :family))) - (apply #'set-face-attribute face nil (car font-list))) - (t (acdw/set-first-face-attribute face (cdr font-list))))) - -(defun acdw/set-emoji-fonts (&rest emoji-fonts) - "Add all installed EMOJI-FONTS to the symbol fontset." - (let ((ffl (font-family-list))) - (dolist (font emoji-fonts) - (when (member font ffl) - (set-fontset-font t 'symbol - (font-spec :family font) nil 'append))))) - -;;; Fringes - -(defun acdw/set-fringes (bitmap-list) - "Apply multiple fringes at once. -BITMAP-LIST is a list of arglists passed directly to -`define-fringe-bitmap', which see." - (dolist (bitmap bitmap-list) - (apply #'define-fringe-bitmap bitmap)) - (redraw-frame)) - -(provide 'acdw-frame) diff --git a/lisp/acdw-irc.el b/lisp/acdw-irc.el deleted file mode 100644 index 4427a4d..0000000 --- a/lisp/acdw-irc.el +++ /dev/null @@ -1,72 +0,0 @@ -;;; acdw-irc.el -*- lexical-binding: t; coding: utf-8-unix -*- - -(require 's nil :noerror) - -(defgroup acdw-irc nil - "Customizations for IRC." - :group 'applications) - -(defcustom acdw-irc/left-margin 16 - "The size of the margin for nicks, etc. on the left." - :type 'integer) - -(defcustom acdw-irc/pre-nick "" - "What to show before a nick." - :type 'string) - -(defcustom acdw-irc/post-nick " | " - "What to show after a nick." - :type 'string) - -(defcustom acdw-irc/pre-my-nick "-" - "What to show before the current user's nick." - :type 'string) - -(defcustom acdw-irc/post-my-nick "-> " - "What to show after the current user's nick." - :type 'string) - -(defcustom acdw-irc/ellipsis "~" - "The ellipsis for when a string is too long." - :type 'string) - - -;;; Convenience functions (I don't want to /depend/ on s.el) - -(if (fboundp 's-repeat) - (defalias 'repeat-string 's-repeat) - (defun repeat-string (num s) - "Make a string of STR repeated NUM times. -Stolen from s.el." - (declare (pure t) (side-effect-free t)) - (let (ss) - (while (> num 0) - (setq ss (cons s ss)) - (setq num (1- num))) - (apply 'concat ss)))) - - -;;; IRC stuff - -(defun acdw-irc/margin-format (str &optional before after alignment) - "Print STR to fit in `acdw-irc/left-margin'. -Optional arguments BEFORE and AFTER specify strings to go -... before and after the string. ALIGNMENT aligns left on nil -and right on t." - (let* ((before (or before "")) - (after (or after "")) - (str-length (length str)) - (before-length (length before)) - (after-length (length after)) - (max-length (- acdw-irc/left-margin 1 (+ before-length after-length))) - (left-over (max 0 (- max-length str-length)))) - (format "%s%s%s%s%s" - before - (if alignment (repeat-string left-over " ") "") - (truncate-string max-length str acdw-irc/ellipsis) - (if alignment "" (repeat-string left-over " ")) - after))) - - -(provide 'acdw-irc) -;;; acdw-irc.el ends here diff --git a/lisp/acdw-lisp.el b/lisp/acdw-lisp.el deleted file mode 100644 index 92fe62e..0000000 --- a/lisp/acdw-lisp.el +++ /dev/null @@ -1,16 +0,0 @@ -;;; acdw-lisp.el -*- lexical-binding: t; coding: utf-8-unix -*- -;; -;; Extras for Lisp modes. - -(defun acdw/eval-region-or-buffer () - (interactive) - (if (region-active-p) - (let ((begin (region-beginning)) - (end (region-end))) - (with-message (format "Evaluating %S -> %S" begin end) - (eval-region begin end))) - (with-message "Evaluating buffer" - (eval-buffer)))) - -(provide 'acdw-lisp) -;;; acdw-lisp.el ends here diff --git a/lisp/acdw-modeline.el b/lisp/acdw-modeline.el deleted file mode 100644 index 0dc23ff..0000000 --- a/lisp/acdw-modeline.el +++ /dev/null @@ -1,232 +0,0 @@ -;;; acdw-modeline.el -*- lexical-binding: t; coding: utf-8-unix -*- -;; Author: Case Duckworth <(rot13-string "npqj@npqj.arg")> -;; Created: Sometime during Covid-19, 2020 -;; Keywords: configuration -;; URL: https://tildegit.org/acdw/emacs - -;; This file is NOT part of GNU Emacs. - -;;; License: -;; Everyone is permitted to do whatever with this software, without -;; limitation. This software comes without any warranty whatsoever, -;; but with two pieces of advice: -;; - Don't hurt yourself. -;; - Make good choices. - -;;; Commentary: -;; `acdw-modeline' is a dumping ground for extra modeline functions, so they -;; don't clutter up `init.el'. - -;;; Code: - -(require 'simple-modeline) -(require 'minions) - -(defcustom acdw-modeline/word-count-modes - (mapcar (lambda (m) (cons m nil)) simple-modeline-word-count-modes) - "Alist of modes to functions that `acdw-modeline/word-count' should dispatch. -If the cdr of the cons cell is nil, use the default function (`count-words'). -Otherwise, cdr should be a function that takes two points (see `count-words')." - :type '(alist :key-type (symbol :tag "Major-Mode") - :value-type function) - :group 'simple-modeline) - -(defun acdw-modeline/buffer-name () ; gonsie - "Display the buffer name in a face reflecting its modified status." - (propertize - (concat - (format " %-20s" - (truncate-string 20 - (string-trim (buffer-name) "*" "*") - "~"))) - 'face 'bold - ;; (if (buffer-modified-p) - ;; 'font-lock-warning-face - ;; 'font-lock-type-face) - 'help-echo (or (buffer-file-name) - (buffer-name)))) - -(defun acdw-modeline/erc () - "ERC indicator for the modeline." - (when (and (bound-and-true-p erc-track-mode) - (boundp 'erc-modified-channels-object)) - (format-mode-line erc-modified-channels-object))) - -(defun acdw-modeline/god-mode-indicator () - "Display an indicator if `god-local-mode' is active." - (when (bound-and-true-p god-local-mode) - " Ω")) - -(defun acdw-modeline/major-mode () - "Displays the current major mode in the mode-line." - (propertize - (concat " " - (or (and (boundp 'delighted-modes) - (cadr (assq major-mode delighted-modes))) - (format-mode-line mode-name))) - 'face 'bold - 'keymap mode-line-major-mode-keymap - 'mouse-face 'mode-line-highlight)) - -(defun acdw-modeline/minions () ; by me - "Display a button for `minions-minor-modes-menu'." - (concat - " " - (propertize - "&" - 'help-echo (format - "Minor modes menu\nmouse-1: show menu.") - 'local-map (purecopy (simple-modeline-make-mouse-map - 'mouse-1 - (lambda (event) - (interactive "e") - (with-selected-window (posn-window - (event-start event)) - (minions-minor-modes-menu))))) - 'mouse-face 'mode-line-highlight))) - -(defun acdw-modeline/nyan-cat () - "Display the nyan cat from function `nyan-mode' in the mode-line." - (when (bound-and-true-p nyan-mode) - (if (eq (bound-and-true-p actually-selected-window) - (get-buffer-window)) - '(" " (:eval (list (nyan-create)))) - `(:propertize " " - display - (space ;; pixel perfect babeeeee - . (:width (,(+ 9 (* 8 (or - (bound-and-true-p nyan-bar-length) - 20)))))))))) - -(defun acdw-modeline/modified () ; modified from `simple-modeline' - "Displays a color-coded buffer modification/read-only -indicator in the mode-line." - (let* ((read-only (and buffer-read-only (buffer-file-name))) - (modified (buffer-modified-p))) - (propertize - (concat " " - (cond - ((string-match-p "\\*.*\\*" (buffer-name)) - "*") - ((derived-mode-p 'special-mode - 'lui-mode) - "~") - (read-only "=") - (modified "+") - (t "-"))) - 'help-echo (format - (concat "Buffer is %s and %smodified\n" - "mouse-1: Toggle read-only status.") - (if read-only "read-only" "writable") - (if modified "" "not ")) - 'local-map (purecopy (simple-modeline-make-mouse-map - 'mouse-1 - (lambda (event) - (interactive "e") - (with-selected-window - (posn-window (event-start event)) - (read-only-mode 'toggle))))) - 'mouse-face 'mode-line-highlight))) - -(defun acdw-modeline/narrowed () - "Display an indication if the buffer is narrowed." - (when (buffer-narrowed-p) - (concat - "" - (propertize - "N" - 'help-echo (format "%s\n%s" - "Buffer is narrowed" - "mouse-2: widen buffer.") - 'local-map (purecopy (simple-modeline-make-mouse-map - 'mouse-2 #'mode-line-widen)) - 'mouse-face 'mode-line-highlight)))) - -(define-minor-mode file-percentage-mode - "Toggle the percentage display in the mode line (File Percentage Mode)." - :init-value t :global t :group 'mode-line) - -(defun acdw-modeline/position () - "Displays the current cursor position in the mode-line. - -Unlike `simple-modeline-segment-position', this changes the first -character from '+' to '-' if the region goes 'backward' -- that -is, if point < mark." - `((line-number-mode - ((column-number-mode - (column-number-indicator-zero-based - (9 " %l/%c") - (9 " %l/%C")) - (6 " L%l"))) - ((column-number-mode - (column-number-indicator-zero-based - (5 " C%c") - (5 " C%C"))) - " ")) - (file-percentage-mode - ((-3 "%p") "%% ")) - ,(if (region-active-p) - (propertize (format "%s%-5d" - (if (and (mark) - (< (point) (mark))) - "-" - "+") - (apply #'+ (mapcar - (lambda (pos) - (- (cdr pos) - (car pos))) - (region-bounds)))) - 'font-lock-face 'font-lock-variable-name-face)))) - -(defun acdw-modeline/reading-mode () - "Display an indicator if currently in reading mode, mine or EWW's." - (concat (if reading-mode "R" "") (if eww-readable-p "w" ""))) - -(defun acdw-modeline/text-scale () - "Display the text scaling from the modeline, if scaled." - ;; adapted from https://github.com/seagle0128/doom-modeline - (when (and (boundp 'text-scale-mode-amount) - (/= text-scale-mode-amount 0)) - (format - (if (> text-scale-mode-amount 0) - " (%+d)" - " (%-d)") - text-scale-mode-amount))) - -(defun acdw-modeline/track () - "Display `tracking-mode' information." - '(tracking-mode - tracking-mode-line-buffers)) - -(defun acdw-modeline/vc-branch () - "Display the version control branch of the current buffer in the modeline." - ;; from https://www.gonsie.com/blorg/modeline.html, from Doom - (if-let ((backend (vc-backend buffer-file-name))) - (concat " " (substring vc-mode (+ (if (eq backend 'Hg) 2 3) 2))))) - -(defun acdw-modeline/wc () - "Display current `wc-buffer-stats'." - (when (bound-and-true-p wc-mode) - (format "%8s" (or (cadr wc-buffer-stats) "[w]")))) - -(defun acdw-modeline/winum () - "Show the `winum' number of the current window in the modeline. -Only shows if there is more than one window." - (when (and (bound-and-true-p winum-mode) - (> winum--window-count 1)) - (format winum-format (winum-get-number-string)))) - -(defun acdw-modeline/word-count () - "Display a buffer word count, depending on the major mode. -Uses `acdw-modeline/word-count-modes' to determine which function to use." - (when-let ((modefun - (assoc major-mode acdw-modeline/word-count-modes #'equal))) - (let* ((fn (or (cdr modefun) - #'count-words)) - (r (region-active-p)) - (min (if r (region-beginning) (point-min))) - (max (if r (region-end) (point-max)))) - (format " %s%dW" (if r "+" "") (funcall fn min max))))) - -(provide 'acdw-modeline) -;;; acdw-modeline.el ends here diff --git a/lisp/acdw-org.el b/lisp/acdw-org.el deleted file mode 100644 index f0a1d49..0000000 --- a/lisp/acdw-org.el +++ /dev/null @@ -1,517 +0,0 @@ -;;; acdw-org.el --- org extras -*- lexical-binding: t; coding: utf-8-unix -*- -;; Author: Various -;; URL: https://tildegit.org/acdw/emacs - -;; This file is NOT part of GNU Emacs. - -;;; License: - -;; Everyone is permitted to do whatever with this software, without -;; limitation. This software comes without any warranty whatsoever, -;; but with two pieces of advice: -;; - Don't hurt yourself. -;; - Make good choices. - -;;; Commentary: - -;; This file is for the weird little `org-mode' functions that just take up -;; space in my main init file. I've tried to give credit where credit is due. - -;; 2021-09-13 Hi readers of "Emacs News!" I just saw that Sacha decided to -;; include this in her weekly newsletter. Thanks for the gold kind stranger, -;; etc. If you're looking for stuff in here that /isn't/ just ripped -;; wholesale from something else on the internet, you'll want the following -;; (updated as I write more/remember to update them): - -;; `acdw-org/fix-blank-lines-in-buffer' -;; `acdw-org/count-words-stupidly' -;; `acdw/org-next-heading-widen' -;; `acdw/org-previous-heading-widen' -;; `acdw-org/work-month-headings' - -;; To be honest, I could easily (and probably should) extract some of these out -;; into their own /real/ libraries. - -;; Until then, just require this file /after/ you require org -- i.e., -;; (with-eval-after-load 'org (require 'acdw-org)) -- or else it'll load every -;; time you start up Emacs. - -;;; Code: - -(require 'dom) -(require 'org) -(require 'org-element) -(require 'ox) -(require 'subr-x) -(require 'calendar) - - -;;; unpackaged.el: https://github.com/alphapapa/unpackaged.el - -(defun acdw-org/element-descendant-of (type element) - "Return non-nil if ELEMENT is a descendant of TYPE. -TYPE should be an element type, like `item' or `paragraph'. -ELEMENT should be a list like that returned by `org-element-context'." - ;; MAYBE: Use `org-element-lineage'. - (when-let* ((parent (org-element-property :parent element))) - (or (eq type (car parent)) - (acdw-org/element-descendant-of type parent)))) - -(defun acdw-org/return-dwim (&optional prefix) - "A helpful replacement for `org-return'. With PREFIX, call `org-return'. - -On headings, move point to position after entry content. In -lists, insert a new item or end the list, with checkbox if -appropriate. In tables, insert a new row or end the table." - ;; Inspired by John Kitchin: - ;; http://kitchingroup.cheme.cmu.edu/blog/2017/04/09/A-better-return-in-org-mode/ - (interactive "P") - ;; Auto-fill if enabled - (when auto-fill-function - (if (listp auto-fill-function) - (dolist (func auto-fill-function) - (funcall func)) - (funcall auto-fill-function))) - (if prefix - ;; Handle prefix args - (pcase prefix - ('(4) (newline)) - ('(16) (newline 2)) - ;; this is ... not ideal. but whatever. - (_ (newline prefix))) - (cond - ;; Act depending on context around point. - ((and org-return-follows-link - (eq 'link (car (org-element-context)))) - ;; Link: Open it. - (org-open-at-point-global)) - - ((org-at-heading-p) - ;; Heading: Move to position after entry content. - ;; NOTE: This is probably the most interesting feature of this function. - (let ((heading-start (org-entry-beginning-position))) - (goto-char (org-entry-end-position)) - (cond ((and (org-at-heading-p) - (= heading-start (org-entry-beginning-position))) - ;; Entry ends on its heading; add newline after - (end-of-line) - (insert "\n\n")) - (t - ;; Entry ends after its heading; back up - (forward-line -1) - (end-of-line) - (when (org-at-heading-p) - ;; At the same heading - (forward-line) - (insert "\n") - (forward-line -1)) - (while (not - (looking-back - (rx (repeat 3 (seq (optional blank) "\n"))) - nil)) - (insert "\n")) - (forward-line -1))))) - - ((org-at-item-checkbox-p) - ;; Checkbox: Insert new item with checkbox. - (org-insert-todo-heading nil)) - - ((org-in-item-p) - ;; Plain list - (let* ((context (org-element-context)) - (first-item-p (eq 'plain-list (car context))) - (itemp (eq 'item (car context))) - (emptyp (eq (org-element-property :contents-begin context) - (org-element-property :contents-end context))) - (item-child-p - (acdw-org/element-descendant-of 'item context))) - ;; The original function from unpackaged just tested the (or ...) test - ;; in this cond, in an if. However, that doesn't auto-end nested - ;; lists. So I made this form a cond and added the (and...) test in - ;; the first position, which is clunky (the delete-region... stuff - ;; comes twice) and might not be needed. More testing, obviously, but - ;; for now, it works well enough. - (cond ((and itemp emptyp) - (delete-region (line-beginning-position) (line-end-position)) - (insert "\n\n")) - ((or first-item-p - (and itemp (not emptyp)) - item-child-p) - (org-insert-item)) - (t (delete-region (line-beginning-position) (line-end-position)) - (insert "\n"))))) - - ((when (fboundp 'org-inlinetask-in-task-p) - (org-inlinetask-in-task-p)) - ;; Inline task: Don't insert a new heading. - (org-return)) - - ((org-at-table-p) - (cond ((save-excursion - (beginning-of-line) - ;; See `org-table-next-field'. - (cl-loop with end = (line-end-position) - for cell = (org-element-table-cell-parser) - always (equal (org-element-property :contents-begin cell) - (org-element-property :contents-end cell)) - while (re-search-forward "|" end t))) - ;; Empty row: end the table. - (delete-region (line-beginning-position) (line-end-position)) - (org-return)) - (t - ;; Non-empty row: call `org-return'. - (org-return)))) - (t - ;; All other cases: call `org-return'. - (org-return))))) - -(defun acdw-org/fix-blank-lines (&optional prefix) - "Ensure blank lines around headings. -Optional PREFIX argument operates on the entire buffer. -Drawers are included with their headings." - (interactive "P") - (org-map-entries (lambda () - (org-with-wide-buffer - ;; `org-map-entries' narrows the buffer, which - ;; prevents us from seeing newlines before the - ;; current heading, so we do this part widened. - (while (not (looking-back "\n\n" nil)) - ;; Insert blank lines before heading. - (insert "\n"))) - (let ((end (org-entry-end-position))) - ;; Insert blank lines before entry content - (forward-line) - (while (and (org-at-planning-p) - (< (point) (point-max))) - ;; Skip planning lines - (forward-line)) - (while (re-search-forward - org-drawer-regexp end t) - ;; Skip drawers. You might think that - ;; `org-at-drawer-p' would suffice, but for - ;; some reason it doesn't work correctly when - ;; operating on hidden text. This works, taken - ;; from `org-agenda-get-some-entry-text'. - (re-search-forward "^[ \t]*:END:.*\n?" end t) - (goto-char (match-end 0))) - (unless (or (= (point) (point-max)) - (org-at-heading-p) - (looking-at-p "\n")) - (insert "\n")))) - t - (if prefix - nil - 'tree))) - - -;;; Generate custom IDs: -;; https://amitp.blogspot.com/2021/04/automatically-generate-ids-for-emacs.html - -(defun acdw-org/generate-custom-ids () - "Generate CUSTOM_ID for any headings that are missing one." - (let ((existing-ids (org-map-entries (lambda () - (org-entry-get nil "CUSTOM_ID"))))) - (org-map-entries - (lambda () - (let* ((custom-id (org-entry-get nil "CUSTOM_ID")) - (heading (org-heading-components)) - (level (nth 0 heading)) - (todo (nth 2 heading)) - (headline (nth 4 heading)) - (slug (acdw-org/title-to-filename headline)) - (duplicate-id (member slug existing-ids))) - (when (and (not custom-id) - (< level 4) - (not todo) - (not duplicate-id)) - (message "Adding entry '%s' to '%s'" slug headline) - (org-entry-put nil "CUSTOM_ID" slug))))))) - -(defun acdw-org/title-to-filename (title) - "Convert TITLE to a reasonable filename." - ;; Based on the slug logic in `org-roam', but `org-roam' also uses a - ;; timestamp, and I only use the slug. - (setq title (downcase title)) - (setq title (replace-regexp-in-string "[^a-zA-Z0-9]+" "-" title)) - (setq title (replace-regexp-in-string "-+" "-" title)) - (setq title (replace-regexp-in-string "^-" "" title)) - (setq title (replace-regexp-in-string "-$" "" title)) - title) - - -;;; ADVICE AND TWEAKS - -;; I definitely got this from somewhere. -;; Correct `org-delete-backward-char' to use `backward-delete-char-untabify' -(defun acdw-org/delete-backward-char (N) - "Keep tables aligned while deleting N characters backward. -When deleting backwards, in tables this function will insert -whitespace in front of the next \"|\" separator, to keep the -table aligned. The table will still be marked for re-alignment -if the field did fill the entire column, because, in this case -the deletion might narrow the column." - (interactive "p") - (save-match-data - (org-check-before-invisible-edit 'delete-backward) - (if (and (= N 1) - (not overwrite-mode) - (not (org-region-active-p)) - (not (eq (char-before) ?|)) - (save-excursion (skip-chars-backward " \t") (not (bolp))) - (looking-at-p ".*?|") - (org-at-table-p)) - (progn (forward-char -1) (org-delete-char 1)) - (backward-delete-char-untabify N) - (org-fix-tags-on-the-fly)))) - -;; Same here. -(defun acdw-org/org-table-copy-down (n) - "Call `org-table-copy-down', or `org-return' outside of a table. -N is passed to the functions." - (interactive "p") - (if (org-table-check-inside-data-field 'noerror) - (org-table-copy-down n) - (acdw-org/return-dwim n))) - -;; This isn't the best code, but it'll do. -(defun acdw-org/count-words-stupidly (start end &optional limit) - "Count words between START and END, ignoring a lot. - -Since this function is, for some reason, pricy, the optional -parameter LIMIT sets a word limit at which to stop counting. -Once the function hits that number, it'll return -LIMIT -instead of the true count." - (interactive (list nil nil)) - (cond ((not (called-interactively-p 'any)) - (let ((words 0) - (continue t)) - (save-excursion - (save-restriction - (narrow-to-region start end) - (goto-char (point-min)) - (while (and continue - (< (point) (point-max))) - (cond - ;; Ignore comments - ((or (org-at-comment-p) - (org-in-commented-heading-p)) - (forward-line)) - ;; Ignore headings - ((or (org-at-heading-p)) - (forward-line)) - ;; Ignore property and log drawers - ((or (looking-at org-drawer-regexp) - (looking-at org-clock-drawer-re)) - (search-forward ":END:" nil :noerror) - (forward-line)) - ;; Ignore DEADLINE and SCHEDULED keywords - ((or (looking-at org-deadline-regexp) - (looking-at org-scheduled-regexp) - (looking-at org-closed-time-regexp)) - (forward-line)) - ;; Ignore tables - ((org-at-table-p) (forward-line)) - ;; Ignore hyperlinks, but count the descriptions - ((looking-at org-link-bracket-re) - (when-let ((desc (match-string-no-properties 5))) - (save-match-data - (setq words (+ words - (length (remove "" - (org-split-string - desc "\\W"))))))) - (goto-char (match-end 0))) - ;; Ignore source blocks - ((org-in-src-block-p) (forward-line)) - ;; Ignore blank lines - ((looking-at "^$") - (forward-line)) - ;; Count everything else - (t - ;; ... unless it's in a few weird contexts - (let ((contexts (org-context))) - (cond ((or (assoc :todo-keyword contexts) - (assoc :priority contexts) - (assoc :keyword contexts) - (assoc :checkbox contexts)) - (forward-word-strictly)) - - (t (setq words (1+ words)) - (if (and limit - (> words limit)) - (setq words (- limit) - continue nil)) - (forward-word-strictly))))))))) - words)) - ((use-region-p) - (message "%d words in region" - (acdw-org/count-words-stupidly (region-beginning) - (region-end)))) - (t - (message "%d words in buffer" - (acdw-org/count-words-stupidly (point-min) - (point-max)))))) - - -;;; Zero-width spaces -;; https://blog.tecosaur.com/tmio/2021-05-31-async.html#easy-zero-width - -(defun insert-zero-width-space () - "Insert a zero-width space." - (interactive) - (insert "\u200b")) - -(defun org-export-remove-zero-width-spaces (text _backend _info) - "Remove zero-width spaces from TEXT." - (unless (org-export-derived-backend-p 'org) - (replace-regexp-in-string "\u200b" "" text))) - - -;;; Insert links .. DWIM -;; https://xenodium.com/emacs-dwim-do-what-i-mean/ - -(defun org-insert-link-dwim () - "Like `org-insert-link' but with personal dwim preferences." - (interactive) - (let* ((point-in-link (org-in-regexp org-link-any-re 1)) - (clipboard-url (when (string-match-p - (rx (sequence bos - (or "http" - "gemini" - "gopher"))) - (current-kill 0)) - (current-kill 0))) - (region-content (when (region-active-p) - (buffer-substring-no-properties (region-beginning) - (region-end))))) - (cond ((and region-content clipboard-url (not point-in-link)) - (delete-region (region-beginning) (region-end)) - (insert (org-link-make-string clipboard-url region-content))) - ((and clipboard-url (not point-in-link)) - (insert (org-link-make-string - clipboard-url - (read-string "title: " - (with-current-buffer - (url-retrieve-synchronously - clipboard-url) - (dom-text - (car - (dom-by-tag (libxml-parse-html-region - (point-min) - (point-max)) - 'title)))))))) - (t - (call-interactively 'org-insert-link))))) - - -;;; Next and previous heading, with widening -(defun acdw/org-next-heading-widen (arg) - "Find the ARGth next org heading, widening if necessary." - (interactive "p") - (let ((current-point (point)) - (point-target (if (> arg 0) (point-max) (point-min)))) - (org-next-visible-heading arg) - (when (and (buffer-narrowed-p) - (= (point) point-target) - (or (and (> arg 0)) - (and (< arg 0) - (= (point) current-point)))) - (widen) - (org-next-visible-heading arg)))) - -(defun acdw/org-previous-heading-widen (arg) - "Find the ARGth previous org heading, widening if necessary." - (interactive "p") - (acdw/org-next-heading-widen (- arg))) - - -;;; Add headings for every day of the work month -;; Gets rid of weekends. - -(defun acdw-org/work-month-headings (&optional month year) - "Create headings for every workday in MONTH and YEAR, or this month. -Workdays are Monday through Friday. This function inserts a new -heading with an inactive timestamp for each workday of MONTH in YEAR. - -I use this function to attempt to organize my work month. I'll -probably abandon it at some point for a better solution (see: -`org-agenda')." - (interactive (list - (read-number "Month: " (car (calendar-current-date))) - (read-number "Year: " (nth 2 (calendar-current-date))))) - (let ((month (or month - (car (calendar-current-date)))) - (year (or year - (car (last (calendar-current-date)))))) - (dotimes (day (calendar-last-day-of-month month year)) - (let* ((day (1+ day)) - (day-of-week (calendar-day-of-week (list month day year)))) - (unless (memq day-of-week '(0 6)) ; weekend - (end-of-line) - (org-insert-heading nil t t) - (insert (concat "[" (mapconcat (lambda (n) - (format "%02d" n)) - (list year month day) - "-") - " " - (nth day-of-week '("Sun" "Mon" "Tue" "Wed" "Thu" - "Fri" "Sat")) - "]"))))))) - -;;; Org task stuff - -(defun org-narrow-to-task () - "Narrow buffer to the nearest task and its subtree." - (interactive) - (save-excursion - (save-match-data - (widen) - (while (not (or (org-entry-is-todo-p) - (org-entry-is-done-p))) - ;; TODO: need a better error message - (org-previous-visible-heading 1)) - (org-narrow-to-subtree)))) - - -;;; Hide everything but the current headline -;; https://stackoverflow.com/questions/25161792/ - -(defun acdw-org/show-next-heading-tidily () - "Show next entry, keeping other entries closed." - (interactive) - (if (save-excursion (end-of-line) (outline-invisible-p)) - (progn (org-show-entry) (outline-show-children)) - (outline-next-heading) - (unless (and (bolp) (org-at-heading-p)) - (org-up-heading-safe) - (outline-hide-subtree) - (error "Boundary reached")) - (org-overview) - (org-reveal t) - (org-show-entry) - (recenter-top-bottom) - (outline-show-children) - (recenter-top-bottom))) - -(defun acdw-org/show-previous-heading-tidily () - "Show previous entry, keeping other entries closed." - (interactive) - (let ((pos (point))) - (outline-previous-heading) - (unless (and (< (point) pos) (bolp) (org-at-heading-p)) - (goto-char pos) - (outline-hide-subtree) - (error "Boundary reached")) - (org-overview) - (org-reveal t) - (org-show-entry) - (recenter-top-bottom) - (outline-show-children) - (recenter-top-bottom))) - - -(provide 'acdw-org) -;;; acdw-org.el ends here - -;; Local Variables: -;; flymake-inhibit: t -;; End: diff --git a/lisp/acdw-re.el b/lisp/acdw-re.el deleted file mode 100644 index eff61e1..0000000 --- a/lisp/acdw-re.el +++ /dev/null @@ -1,151 +0,0 @@ -;;; acdw-re.el -*- lexical-binding: t; coding: utf-8-unix -*- -;; Author: Case Duckworth <(rot13-string "npqj@npqj.arg")> -;; Created: 2021-04-29 -;; Keywords: configuration -;; URL: https://tildegit.org/acdw/emacs - -;; This file is NOT part of GNU Emacs. - -;;; License: -;; Everyone is permitted to do whatever with this software, without -;; limitation. This software comes without any warranty whatsoever, -;; but with two pieces of advice: -;; - Don't hurt yourself. -;; - Make good choices. - -;;; Commentary: -;; Pulled mostly from karthinks: -;; https://karthinks.com/software/bridging-islands-in-emacs-1/ - -;; UPDATED CODE: -;; https://github.com/karthink/.emacs.d/blob/master/init.el#L981 -;; https://github.com/karthink/.emacs.d/blob/master/lisp/reb-fix.el - -;;; Code: - -(require 're-builder) - -(defvar my/re-builder-positions nil - "Store point and region bounds before calling `re-builder'.") - -(defun my/re-builder-save-state (&rest _) - "Save the point and region before calling `re-builder'." - (setq my/re-builder-positions - (cons (point) - (when (region-active-p) - (list (region-beginning) - (region-end)))))) - -(defun reb-replace-regexp (&optional delimited) - "Run `query-replace-regexp' with the contents of `re-builder'. -With non-nil optional argument DELIMITED, only replace matches -surrounded by word boundaries." - (interactive "P") - (reb-update-regexp) - (let* ((re (reb-target-binding reb-regexp)) - (replacement (query-replace-read-to - re - (concat "Query replace" - (if current-prefix-arg - (if (eq current-prefix-arg '-) - " backward" - " word") - "") - " regexp" - (if (with-selected-window reb-target-window - (region-active-p)) - " in region" - "")) - t)) - (pnt (car my/re-builder-positions)) - (beg (cadr my/re-builder-positions)) - (end (caddr my/re-builder-positions))) - (with-selected-window reb-target-window - (goto-char (or pnt 0)) - (setq my/re-builder-positions nil) - (reb-quit) - (query-replace-regexp re replacement delimited beg end)))) - -;; Restrict re-builder matches to region - -(defun reb-update-overlays (&optional subexp) - "Switch to `reb-target-buffer' and mark all matches of `reb-regexp'. -If SUBEXP is non-nil mark only the corresponding sub-expressions." - (let* ((re (reb-target-binding reb-regexp)) - (subexps (reb-count-subexps re)) - (matches 0) - (submatches 0) - firstmatch - here - start end - firstmatch-after-here) - (with-current-buffer reb-target-buffer - (setq here - (if reb-target-window - (with-selected-window reb-target-window (window-point)) - (point)) - start - (if (region-active-p) - (nth 1 my/re-builder-positions) - (nth 0 my/re-builder-positions)) - end - (if (region-active-p) - (nth 2 my/re-builder-positions) - (point-max))) - (reb-delete-overlays) - (goto-char (or start 0)) - (while (and (not (eobp)) - (re-search-forward re end t) - (or (not reb-auto-match-limit) - (< matches reb-auto-match-limit))) - (when (and (= 0 (length (match-string 0))) - (not (eobp))) - (forward-char 1)) - (let ((i 0) - suffix max-suffix) - (setq matches (1+ matches)) - (while (<= i subexps) - (when (and (or (not subexp) (= subexp i)) - (match-beginning i)) - (let ((overlay (make-overlay (match-beginning i) - (match-end i))) - ;; When we have exceeded the number of provided faces, - ;; cycle thru them where `max-suffix' denotes the maximum - ;; suffix for `reb-match-*' that has been defined and - ;; `suffix' the suffix calculated for the current match. - (face - (cond - (max-suffix - (if (= suffix max-suffix) - (setq suffix 1) - (setq suffix (1+ suffix))) - (intern-soft (format "reb-match-%d" suffix))) - ((intern-soft (format "reb-match-%d" i))) - ((setq max-suffix (1- i)) - (setq suffix 1) - ;; `reb-match-1' must exist. - 'reb-match-1)))) - (unless firstmatch (setq firstmatch (match-data))) - (unless firstmatch-after-here - (when (> (point) here) - (setq firstmatch-after-here (match-data)))) - (setq reb-overlays (cons overlay reb-overlays) - submatches (1+ submatches)) - (overlay-put overlay 'face face) - (overlay-put overlay 'priority i))) - (setq i (1+ i)))))) - (let ((count (if subexp submatches matches))) - (message "%s %smatch%s%s" - (if (= 0 count) "No" (int-to-string count)) - (if subexp "subexpression " "") - (if (= 1 count) "" "es") - (if (and reb-auto-match-limit - (= reb-auto-match-limit count)) - " (limit reached)" ""))) - (when firstmatch - (store-match-data (or firstmatch-after-here firstmatch)) - (reb-show-subexp (or subexp 0))))) - -(provide 'acdw-re) - -;;; acdw-re.el ends here diff --git a/lisp/acdw-reading.el b/lisp/acdw-reading.el deleted file mode 100644 index ff4f0c2..0000000 --- a/lisp/acdw-reading.el +++ /dev/null @@ -1,100 +0,0 @@ -;;; acdw-reading.el --- minor mode for reading -*- lexical-binding: t -*- - -;; Copyright 2021 Case Duckworth <(rot13-string "npqj@npqj.arg")> -;; This file is NOT part of GNU Emacs. - -;;; License: - -;; Everyone is permitted to do whatever with this software, without -;; limitation. This software comes without any warranty whatsoever, -;; but with two pieces of advice: -;; - Don't hurt yourself. -;; - Make good choices. - -;;; Commentary: - -;; here is my attempt at a reading mode. - -;;; Code: - -;;; Customizations - -(defgroup reading nil - "Group for Reading mode customizations." - :prefix "reading-" - :group 'convenience) ; i need to figure this out - -(defcustom reading-vars '((indicate-empty-lines . nil) - (indicate-buffer-boundaries . nil)) - "Alist of variables to set in function `reading-mode'. -The car of each cell is the variable name, and the cdr is the -value to set it to." - :type '(alist :key-type variable - :value-type sexp)) - -(defcustom reading-modes '((display-fill-column-indicator-mode . -1) - (blink-cursor-mode . -1)) - "Alist of modes to set in function `reading-mode'. -The car of each cell is the function name, and the cdr is the -value to call it with." - :type '(alist :key-type function - :value-type sexp)) - -;;; Internal - -(defvar reading--remembered-template "reading--remembered-%s-value" - "The template passed to `format' for remembered modes and variables.") - -(defun reading--remember (things func) - "Apply FUNC to THINGS, remembering their previous value for later." - (declare (indent 1)) - (unless (listp things) - (setq things (list things))) - (dolist (thing things) - (set (make-local-variable - (intern (format reading--remembered-template thing))) - (and (boundp thing) - (symbol-value thing))) - (funcall func thing))) - -(defun reading--recall (things func) - "Recall previously remembered THINGS by applying FUNC to them. -FUNC should be a function with the signature (THING REMEMBERED-SETTING)." - (declare (indent 1)) - (unless (listp things) - (setq things (list things))) - (dolist (thing things) - (with-demoted-errors "reading--recall: %S" - (let ((value (symbol-value - (intern - (format reading--remembered-template thing))))) - (funcall func thing value))))) - -;;; Mode - -;;;###autoload -(define-minor-mode reading-mode - "A mode for reading." - :init-value nil - :lighter " Read" - :keymap (make-sparse-keymap) - (if reading-mode - ;; turn on - (progn - (reading--remember (mapcar #'car reading-vars) - (lambda (var) - (set (make-local-variable var) - (cdr (assoc var reading-vars))))) - (reading--remember (mapcar #'car reading-modes) - (lambda (mode) - (funcall mode (cdr (assoc mode reading-modes)))))) - ;; turn off - (reading--recall (mapcar #'car reading-vars) - (lambda (var orig-val) - (set (make-local-variable var) orig-val))) - (reading--recall (mapcar #'car reading-modes) - (lambda (mode orig-setting) - (funcall mode (if orig-setting +1 -1)))))) - -(provide 'acdw-reading) -;;; acdw-reading.el ends here diff --git a/lisp/acdw-setup.el b/lisp/acdw-setup.el deleted file mode 100644 index 33ab835..0000000 --- a/lisp/acdw-setup.el +++ /dev/null @@ -1,103 +0,0 @@ -;;; acdw-setup.el -- my `setup' commands -*- lexical-binding: t -*- - -;; Author: Case Duckworth <(rot13-string "npqj@npqj.arg")> - -;; This file is NOT part of GNU Emacs. - -;;; License: -;; Everyone is permitted to do whatever with this software, without -;; limitation. This software comes without any warranty whatsoever, -;; but with two pieces of advice: -;; - Don't hurt yourself. -;; - Make good choices. - -;;; Commentary: - -;; setup.el makes defining local macros for `setup' forms quite simple, at -;; least to my mind. Here are some of the ones I've defined. - -;;; Code: - -(require 'setup) - -(setup-define :autoload - (lambda (func) - (if (listp func) - (let ((plist (cdr func))) - `(autoload ',(car func) - ,(symbol-name (setup-get 'feature)) - ,(plist-get plist :docstring) - ,(plist-get plist :interactive) - ,(plist-get plist :type))) - `(autoload ',func ,(symbol-name (setup-get 'feature))))) - :documentation "Autoload FUNC from FEATURE. -`:autoload' can be passed a list with keywords: -:docstring - The DOCSTRING to give the autoloaded function. -:interactive - Whether the function is INTERACTIVE or not. -:type - Either `nil', `keymap', or `macro': see `autoload' for details." - :repeatable t) - -(setup-define :require-after - (lambda (seconds) - `(run-with-idle-timer ,seconds nil - #'require ',(setup-get 'feature) nil t)) - :documentation "Requre FEATURE, after SECONDS idle time.") - -(setup-define :face - (lambda (face spec) - `(custom-set-faces '(,face ,spec 'now "Customized by `setup'."))) - :documentation "Customize FACE with SPEC using `custom-set-faces'." - :repeatable t) - -(setup-define :file-match - ;; Hotfix; patch here: https://github.com/phikal/setup.el/pull/1 - (lambda (pat) - `(add-to-list 'auto-mode-alist (cons ,pat ',(setup-get 'mode)))) - :documentation "Associate the current mode with files that match PAT." - :debug '(form) - :repeatable t) - -(setup-define :straight - (lambda (recipe) - `(unless (straight-use-package ',recipe) - ,(setup-quit))) - :documentation - "Install RECIPE with `straight-use-package'. -This macro can be used as HEAD, and will replace itself with the -first RECIPE's package." - :repeatable t - :shorthand (lambda (sexp) - (let ((recipe (cadr sexp))) - (if (consp recipe) - (car recipe) - recipe)))) - -(setup-define :straight-when - (lambda (recipe condition) - `(if ,condition - (straight-use-package ',recipe) - ,(setup-quit))) - :documentation - "Install RECIPE with `straight-use-package' when CONDITION is met. -If CONDITION is false, stop evaluating the body. This macro can -be used as HEAD, and will replace itself with the RECIPE's -package. This macro is not repeatable." - :repeatable nil - :indent 1 - :shorthand (lambda (sexp) - (let ((recipe (cadr sexp))) - (if (consp recipe) (car recipe) recipe)))) - -;; https://www.emacswiki.org/emacs/SetupEl -(setup-define :load-after - (lambda (&rest features) - (let ((body `(require ',(setup-get 'feature)))) - (dolist (feature (if (listp features) - (nreverse features) - (list features))) - (setq body `(with-eval-after-load ',feature ,body))) - body)) - :documentation "Load the current feature after FEATURES.") - -(provide 'acdw-setup) -;;; acdw-setup.el ends here diff --git a/lisp/acdw-ytel.el b/lisp/acdw-ytel.el deleted file mode 100644 index 276323d..0000000 --- a/lisp/acdw-ytel.el +++ /dev/null @@ -1,75 +0,0 @@ -;;; acdw-ytel.el --- bespoke functions for ytel -*- lexical-binding: t -*- - -;;; Commentary: - -;; Extra code for the ytel package: -;; https://github.com/gRastello/ytel - -;;; Code: - -(require 'ytel nil t) - -(defun acdw/ytel-current-video-link () - "Get the link of the video at point." - (let* ((video (ytel-get-current-video)) - (id (ytel-video-id video))) - (concat "https://www.youtube.com/watch?v=" id))) - -(defun acdw/ytel-watch () ; This could possibly use `browse-url'. - "Stream video at point in mpv." - (interactive) - (start-process "ytel mpv" nil - "mpv" - (acdw/ytel-current-video-link) - "--ytdl-format=bestvideo[height<=?720]+bestaudio/best") - (message "Starting streaming...")) - -(defun acdw/ytel-copy-link () - "Copy link of the video at point." - (interactive) - (let ((link (acdw/ytel-current-video-link))) - (kill-new link) - (message "Copied %s to kill-ring" link))) - - -;;; YTDIOUS: https://github.com/spiderbit/ytdious -;; a fork of ytel that uses table-view or w/e. looks nicer - -(require 'ytdious nil t) - -(defun acdw/ytdious-current-video-link () - "Get the link of the video at point." - (let* ((video (ytdious-get-current-video)) - (id (ytdious-video-id-fun video))) - (concat "https://www.youtube.com/watch?v=" id))) - -(defun acdw/ytdious-watch () ; This could possibly use `browse-url'. - "Stream video at point in mpv." - (interactive) - (let ((link (acdw/ytdious-current-video-link))) - (start-process "ytdious mpv" nil - "mpv" - link - "--ytdl-format=bestvideo[height<=?720]+bestaudio/best") - (message "Streaming %s..." link))) - -(defun acdw/ytdious-copy-link () - "Copy link of the video at point." - (interactive) - (let ((link (acdw/ytdious-current-video-link))) - (kill-new link) - (message "Copied %s to kill-ring" link))) - -(defun acdw/ytdious-quit () - "Quit ytdious." - ;; This corrects an error with `ytdious-quit' where it doesn't have the right - ;; buffer setup. - (interactive) - (quit-window)) - -;;; Ignore `ytdious-show-image-asyncron' because it's buggy. - -(defalias 'ytdious-show-image-asyncron #'ignore) - -(provide 'acdw-ytel) -;;; acdw-ytel.el ends here diff --git a/lisp/acdw.el b/lisp/acdw.el index 56b661f..b13c9b6 100644 --- a/lisp/acdw.el +++ b/lisp/acdw.el @@ -1,869 +1,46 @@ -;;; acdw.el --- miscellaneous -*- lexical-binding: t; coding: utf-8-unix -*- - -;; Author: Case Duckworth <(rot13-string "npqj@npqj.arg")> -;; Created: Sometime during Covid-19, 2020 -;; Keywords: configuration -;; URL: https://tildegit.org/acdw/emacs - -;; This file is NOT part of GNU Emacs. - -;;; License: -;; Everyone is permitted to do whatever with this software, without -;; limitation. This software comes without any warranty whatsoever, -;; but with two pieces of advice: -;; - Don't hurt yourself. -;; - Make good choices. +;;; acdw.el --- various meta-whatevers -*- lexical-binding: t -*- ;;; Commentary: -;; `acdw.el' contains `acdw/map', its mode, and assorted ease-of-life -;; functions for me, acdw. - -;;; Code: - -(require 'cl-lib) -(require 'auth-source) -(require 'recentf) - -;;; Variables - -(defconst acdw/system - (pcase system-type - ('gnu/linux :home) - ((or 'msdos 'windows-nt) :work) - (_ :other)) - "Which computer system is currently being used.") - -(defmacro acdw/system (&rest args) - "Macro for interfacing, depending on ARGS, with symbol `acdw/system'. - -When called without arguments, it returns symbol `acdw/system'. When -called with one (symbol) argument, it returns (eq acdw/system -ARG). When called with multiple arguments or a list, it returns -`pcase' over each argument." - (cond - ((null args) acdw/system) - ((atom (car args)) - `(when (eq acdw/system ,(car args)) - ,(car args))) - (t - `(pcase acdw/system - ,@args)))) - - -;;; Utility functions -;; I don't prefix these because ... reasons. Honestly I probably should prefix -;; them. - -(defun truncate-string (len str &optional ellipsis) - "If STR is longer than LEN, cut it down and add ELLIPSIS to the end. -When not specified, ELLIPSIS defaults to '...'." - (declare (pure t) (side-effect-free t)) - (unless ellipsis - (setq ellipsis "...")) - (if (> (length str) len) - (format "%s%s" (substring str 0 (- len (length ellipsis))) ellipsis) - str)) - -;; Why isn't this a thing??? -(defmacro fbound-and-true-p (func) - "Return the value of function FUNC if it is bound, else nil." - `(and (fboundp ,func) ,func)) - -(defmacro when-unfocused (name &rest forms) - "Define a function NAME, executing FORMS, for when Emacs is unfocused." - (declare (indent 1)) - (let ((func-name (intern (concat "when-unfocused-" (symbol-name name))))) - `(progn - (defun ,func-name () "Defined by `when-unfocused'." - (when (seq-every-p #'null - (mapcar #'frame-focus-state (frame-list))) - ,@forms)) - (add-function :after after-focus-change-function #',func-name)))) - -(defmacro with-eval-after-loads (features &rest body) - "Execute BODY after FEATURES are loaded. -This macro simplifies `with-eval-after-load' for multiple nested -features." - (declare (indent 1) - (debug (form def-body))) - (unless (listp features) - (setq features (list features))) - (if (null features) - (macroexp-progn body) - (let* ((this (car features)) - (rest (cdr features))) - `(with-eval-after-load ',this - (with-eval-after-loads ,rest ,@body))))) - -(defmacro with-message (message &rest body) - "Execute BODY, messaging 'MESSAGE...' before and 'MESSAGE... Done.' after." - (declare (indent 1)) - ;; Wrap a progn inside a prog1 to return the return value of the body. - `(prog1 - (progn (message "%s..." ,message) - ,@body) - (message "%s... Done." ,message))) - -(defun clone-buffer-write-file (filename &optional confirm) - "Clone current buffer to a file named FILENAME and switch. -FILENAME and CONFIRM are passed directly to `write-file'." - (interactive ; stolen from `write-file' - (list (if buffer-file-name - (read-file-name "Write file: " - nil nil nil nil) - (read-file-name "Write file: " default-directory - (expand-file-name - (file-name-nondirectory (buffer-name)) - default-directory) - nil nil)) - (not current-prefix-arg))) - (let ((buf (clone-buffer nil nil))) - (with-current-buffer buf - (write-file filename confirm)) - (switch-to-buffer buf))) - -;; https://old.reddit.com/r/emacs/comments/pjwkts -(defun acdw/goto-last-row () - "Move point to last row of buffer, but save the column." - (interactive) - (let ((col (current-column))) - (goto-char (point-max)) - (move-to-column col t))) - -(defun acdw/goto-first-row () - "Move point to first row of buffer, but save the column." - (interactive) - (let ((col (current-column))) - (goto-char (point-min)) - (move-to-column col t))) - -(defun dos2unix (buffer) - "Replace \r\n with \n in BUFFER." - (interactive "*b") - (save-excursion - (with-current-buffer buffer - (goto-char (point-min)) - (while (search-forward (string ?\C-m ?\C-j) nil t) - (replace-match (string ?\C-j) nil t))))) - -(defun expand-file-name-exists-p (&rest args) - "Return `expand-file-name' ARGS if it exists, or nil." - (let ((file (apply #'expand-file-name args))) - (if (file-exists-p file) - file - nil))) - -(defun kill-region-or-backward-word (arg) - "If region is active, kill; otherwise kill word backward with ARG." - (interactive "p") - (if (region-active-p) - (kill-region (region-beginning) (region-end)) - (if (bound-and-true-p paredit-mode) - (paredit-backward-kill-word) - (backward-kill-word arg)))) - -(defun unfill-buffer (&optional buffer-or-name) - "Unfill entire contents of BUFFER-OR-NAME." - (with-current-buffer (or buffer-or-name (current-buffer)) - (save-excursion - (save-restriction - (unfill-region (point-min) (point-max)))))) - -(defun waterfall-list (car list rest) - "Cons CAR with each element in LIST in a waterfall fashion, end with REST. -For use with the `with-eval-after-loads' function." - (cond ((atom list) `(,car ',list ,@rest)) - ((= 1 (length list)) `(,car ',(car list) ,@rest)) - (t - `(,car ',(car list) - ,(waterfall-list car (cdr list) rest))))) - - -;;; Comment-or-uncomment-sexp -;; from https://endlessparentheses.com/a-comment-or-uncomment-sexp-command.html - -(defun uncomment-sexp (&optional n) - "Uncomment N sexps around point." - (interactive "P") - (let* ((initial-point (point-marker)) - (inhibit-field-text-motion t) - (p) - (end (save-excursion - (when (elt (syntax-ppss) 4) - (re-search-backward comment-start-skip - (line-beginning-position) - t)) - (setq p (point-marker)) - (comment-forward (point-max)) - (point-marker))) - (beg (save-excursion - (forward-line 0) - (while (and (not (bobp)) - (= end (save-excursion - (comment-forward (point-max)) - (point)))) - (forward-line -1)) - (goto-char (line-end-position)) - (re-search-backward comment-start-skip - (line-beginning-position) - t) - (ignore-errors - (while (looking-at-p comment-start-skip) - (forward-char -1))) - (point-marker)))) - (unless (= beg end) - (uncomment-region beg end) - (goto-char p) - ;; Indentify the "top-level" sexp inside the comment. - (while (and (ignore-errors (backward-up-list) t) - (>= (point) beg)) - (skip-chars-backward (rx (syntax expression-prefix))) - (setq p (point-marker))) - ;; Re-comment everything before it. - (ignore-errors - (comment-region beg p)) - ;; And everything after it. - (goto-char p) - (forward-sexp (or n 1)) - (skip-chars-forward "\r\n[:blank:]") - (if (< (point) end) - (ignore-errors - (comment-region (point) end)) - ;; If this is a closing delimiter, pull it up. - (goto-char end) - (skip-chars-forward "\r\n[:blank:]") - (when (eq 5 (car (syntax-after (point)))) - (delete-indentation)))) - ;; Without a prefix, it's more useful to leave point where - ;; it was. - (unless n - (goto-char initial-point)))) - -(defun comment-sexp--raw () - "Comment the sexp at point or ahead of point." - (pcase (or (bounds-of-thing-at-point 'sexp) - (save-excursion - (skip-chars-forward "\r\n[:blank:]") - (bounds-of-thing-at-point 'sexp))) - (`(,l . ,r) - (goto-char r) - (skip-chars-forward "\r\n[:blank:]") - (save-excursion - (comment-region l r)) - (skip-chars-forward "\r\n[:blank:]")))) - -(defun comment-or-uncomment-sexp (&optional n) - "Comment the sexp at point and move past it. -If already inside (or before) a comment, uncomment instead. -With a prefix argument N, (un)comment that many sexps." - (interactive "P") - (if (or (elt (syntax-ppss) 4) - (< (save-excursion - (skip-chars-forward "\r\n[:blank:]") - (point)) - (save-excursion - (comment-forward 1) - (point)))) - (uncomment-sexp n) - (dotimes (_ (or n 1)) - (comment-sexp--raw)))) - - -;;; Sort sexps -;; from https://github.com/alphapapa/unpackaged.el#sort-sexps -;; and https://github.com/alphapapa/unpackaged.el/issues/20 - -(defun sort-sexps (beg end &optional key-fn sort-fn) - "Sort sexps between BEG and END. -Comments stay with the code below. - -Optional argument KEY-FN will determine where in each sexp to -start sorting. e.g. (lambda (sexp) (symbol-name (car sexp))) - -Optional argument SORT-FN will determine how to sort two sexps' -strings. It's passed to `sort'. By default, it sorts the sexps -with `string<' starting with the key determined by KEY-FN." - (interactive "r") - (cl-flet ((skip-whitespace () (while (looking-at (rx (1+ (or space "\n")))) - (goto-char (match-end 0)))) - (skip-both () (while (cond ((or (nth 4 (syntax-ppss)) - (ignore-errors - (save-excursion - (forward-char 1) - (nth 4 (syntax-ppss))))) - (forward-line 1)) - ((looking-at (rx (1+ (or space "\n")))) - (goto-char (match-end 0))))))) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (goto-char beg) - (skip-both) - (cl-destructuring-bind (sexps markers) - (cl-loop do (skip-whitespace) - for start = (point-marker) - for sexp = (ignore-errors - (read (current-buffer))) - for end = (point-marker) - while sexp - ;; Collect the real string, then one used for sorting. - collect (cons (buffer-substring (marker-position start) - (marker-position end)) - (save-excursion - (goto-char (marker-position start)) - (skip-both) - (if key-fn - (funcall key-fn sexp) - (buffer-substring - (point) - (marker-position end))))) - into sexps - collect (cons start end) - into markers - finally return (list sexps markers)) - (setq sexps (sort sexps (if sort-fn sort-fn - (lambda (a b) - (string< (cdr a) (cdr b)))))) - (cl-loop for (real . sort) in sexps - for (start . end) in markers - do (progn - (goto-char (marker-position start)) - (insert-before-markers real) - (delete-region (point) (marker-position end))))))))) - -(defun acdw/sort-setups () - "Sort `setup' forms in the current buffer. -Actually sorts all forms, but based on the logic of `setup'. -In short, DO NOT USE THIS FUNCTION!!!" - (save-excursion - (sort-sexps - (point-min) (point-max) - ;; Key function - nil - ;; Sort function - (lambda (s1 s2) ; oh god, this is worse. - (let* ((s1 (cdr s1)) (s2 (cdr s2)) ; for the strings themselves - (require-regexp (rx bos (* nonl) ":require")) - (straight-regexp (rx bos (* nonl) ":straight")) - (s1-require (string-match require-regexp s1)) - (s2-require (string-match require-regexp s2)) - (s1-straight (string-match straight-regexp s1)) - (s2-straight (string-match straight-regexp s2))) - (cond - ;; Straight forms require some weirdness - ((and s1-straight s2-straight) - (let* ((r (rx ":straight" (? "-when") (* space) (? "("))) - (s1 (replace-regexp-in-string r "" s1)) - (s2 (replace-regexp-in-string r "" s2))) - (string< s1 s2))) - ;; requires should go first - ((and s1-require (not s2-require)) t) - ((and (not s1-require) s2-require) nil) - ;; straights should go last - ((and s1-straight (not s2-straight)) nil) - ((and (not s1-straight) s2-straight) t) - ;; else, just sort em. - (t (string< s1 s2)))))))) - - -;;; Emacs configuration functions - -(defun emacs-git-pull-config (&optional remote branch) - "`git-pull' Emacs' configuration from REMOTE and BRANCH. -REMOTE defaults to 'origin', BRANCH to 'main'." - (let ((remote (or remote "origin")) - (branch (or branch "main"))) - (with-message (format "Pulling Emacs's configuration from %s" branch) - (shell-command (concat "git -C " - "\"" (expand-file-name user-emacs-directory) "\"" - " pull " remote " " branch) - (get-buffer-create "*emacs-git-pull-config-output*") - (get-buffer-create "*emacs-git-pull-config-error*"))))) - -(defun emacs-reload (&optional git-pull-first) - "Reload Emacs's configuration files. -With a prefix argument GIT-PULL-FIRST, run git pull on the repo -first." - (interactive "P") - (when git-pull-first - (emacs-git-pull-config)) - (let ((init-files (append - ;; Load lisp libraries first, in case their functionality - ;; is used by {early-,}init.el - (let* ((dir (expand-file-name "lisp/" - user-emacs-directory)) - (full-name (lambda (f) - (concat - (file-name-as-directory dir) f)))) - (mapcar full-name (directory-files dir nil "\\.el\\'"))) - ;; Load regular init files - (list (locate-user-emacs-file "early-init.el") - (locate-user-emacs-file "init.el" ".emacs")))) - (debug-on-error t)) - (with-message "Saving init files" - (save-some-buffers :no-confirm (lambda () (member (buffer-file-name) - init-files)))) - (dolist (file init-files) - (with-message (format "Loading %s" file) - (when (file-exists-p file) - (load-file file)))))) - - -;;; Specialized functions - -(defun acdw/copy-region-plain (beg end) - "Copy a region from BEG to END to clipboard, removing all Org formatting." - (interactive "r") - (let ((s (buffer-substring-no-properties beg end)) - (extracted-heading (when (derived-mode-p 'org-mode) - (acdw/org-extract-heading-text)))) - (with-temp-buffer - (insert s) - (let ((sentence-end-double-space nil)) - ;; Remove org stuff - (when extracted-heading ; Replace org heading with plaintext - (goto-char (point-min)) - (kill-line) - (insert extracted-heading)) - ;; Delete property drawers - (replace-regexp org-property-drawer-re "") - ;; Delete logbook drawers - (replace-regexp org-logbook-drawer-re "") - ;; Replace list items with their contents, paragraphed - (replace-regexp org-list-full-item-re " -\4") - ;; Delete comment lines - (replace-regexp (concat org-comment-regexp ".*$") "") - ;; Re-fill text for clipboard - (unfill-region (point-min) (point-max)) - (flush-lines "^$" (point-min) (point-max))) - ;; Copy buffer - (copy-region-as-kill (point-min) (point-max)))) - (when (called-interactively-p 'interactive) - (indicate-copied-region)) - (setq deactivate-mark t) - nil) -;; https://emacs.stackexchange.com/questions/36366/ -(defun html-body-id-filter (output backend info) - "Remove random ID attributes generated by Org." - (when (eq backend 'html) - (replace-regexp-in-string - " id=\"[[:alpha:]-]*org[[:alnum:]]\\{7\\}\"" - "" - output t))) +;; What's that saying about how the hardest things in computer science +;; are naming and off-by-one errors? Well, the naming one I know very +;; well. I've been trying to figure out a good way to prefix my +;; bespoke functions, other stuff I found online, and various emacs +;; lisp detritus for quite some time (I reckon at over a year, as of +;; 2021-11-02). Finally, I found the answer in the writings of Daniel +;; Mendler: I'll prefix everything with a `+' ! -(defun html-body-div-filter (output backend info) - "Remove wrapping divs generated by Org." - (when (eq backend 'html) - (replace-regexp-in-string - "]*>\n*" "" - output t))) +;; To that end, pretty much everything in lisp/ will have a filename +;; like "+org.el", except of course this file, and maybe a few +;; /actually original/ libraries I haven't had the wherewithal to +;; package out properly yet. -(defun org-demote-headings (backend) - (while (/= (point) (point-max)) - (org-next-visible-heading 1) - (org-demote-subtree))) +;; Is it perfect? No. Is it fine? Yes. Here it is. -(defun acdw/org-export-copy-html () - "Copy a tree as HTML." - (interactive) - (require 'ox-html) - (org-export-with-buffer-copy - ;; (add-hook 'org-export-before-parsing-hook #'org-demote-headings nil t) - (let ((extracted-heading (acdw/org-extract-heading-text)) - (org-export-show-temporary-export-buffer nil) - (org-export-filter-final-output-functions - '(html-body-id-filter html-body-div-filter))) - (insert "* ORG IS STUPID SOMETIMES\n") - (goto-char (point-min)) - (org-html-export-as-html nil t nil t - (list :with-smart-quotes nil - :with-special-strings t)) - (with-current-buffer "*Org HTML Export*" - (goto-char (point-min)) - (replace-regexp "

.*

" "") - (insert "

" extracted-heading "

") - (flush-lines "^$" (point-min) (point-max)) - (let ((sentence-end-double-space nil)) - (unfill-region (point-min) (point-max))) - (replace-regexp " +" "

" nil (point-min) (point-max)) - (replace-regexp " +

" "

" nil (point-min) (point-max)) - (copy-region-as-kill (point-min) (point-max))))) - (when (called-interactively-p 'interactive) - (indicate-copied-region)) - (setq deactivate-mark t) - nil) - -(defun acdw/org-export-copy () - "Copy a tree as ASCII." - (interactive) - (require 'ox-ascii) - (let ((extracted-heading (acdw/org-extract-heading-text))) - ;; Export to ASCII - not async, subtree only, visible-only, body-only - (let ((org-export-show-temporary-export-buffer nil)) - (org-ascii-export-as-ascii nil t nil t - (list :with-smart-quotes t - :with-special-strings t))) - (with-current-buffer "*Org ASCII Export*" - (goto-char (point-min)) - (insert extracted-heading) - (newline 2) - - (replace-regexp org-list-full-item-re "\n\4") - - (let ((sentence-end-double-space nil)) - (unfill-region (point-min) (point-max))) - (flush-lines "^$" (point-min) (point-max)) - - (copy-region-as-kill (point-min) (point-max))) - - (when (called-interactively-p 'interactive) - (indicate-copied-region)) - (setq deactivate-mark t) - nil)) - -(defun acdw/org-extract-heading-text () - "Extract the heading text from an `org-mode' heading." - (let ((heading (org-no-properties (org-get-heading t t t t)))) - (message - (replace-regexp-in-string org-link-bracket-re - (lambda (match) - (match-string-no-properties 2 match)) - heading)))) - -(defun acdw/sync-dir (&optional file make-directory) - "Return FILE from ~/Sync. -Optional argument MAKE-DIRECTORY makes the directory. -Logic is as in `acdw/dir', which see." - (let ((dir (expand-file-name (convert-standard-filename "~/Sync/")))) - (if file - (let ((file-name (expand-file-name (convert-standard-filename file) - dir))) - (when make-directory - (make-directory (file-name-directory file-name) 'parents)) - file-name) - dir))) - -(defun acdw/dir (&optional file make-directory) - "Place Emacs files in one place. - -If called without parameters, `acdw/dir' expands to -~/.emacs.d/var or similar. If called with FILE, `acdw/dir' -expands FILE to ~/.emacs.d/var, optionally making its directory -if MAKE-DIRECTORY is non-nil." - (let ((dir (expand-file-name (convert-standard-filename "var/") - user-emacs-directory))) - (if file - (let ((file-name (expand-file-name (convert-standard-filename file) - dir))) - (when make-directory - (make-directory (file-name-directory file-name) 'parents)) - file-name) - dir))) - -(defun acdw/find-emacs-source () ;; doesn't work right now - "Find where Emacs' source tree is." - (acdw/system - (:work (expand-file-name - (concat "~/src/emacs-" emacs-version "/src"))) - (:home (expand-file-name "~/src/pkg/emacs/src/emacs-git/src")) - (:other nil))) - -(defun acdw/gc-disable () - "Functionally disable the Garbage collector." - (setq gc-cons-threshold most-positive-fixnum - gc-cons-percentage 0.8)) - -(defun acdw/gc-enable () - "Enable the Garbage collector." - (setq gc-cons-threshold (* 800 1024 1024) - gc-cons-percentage 0.1)) - -(defun acdw/insert-iso-date (arg) - "Insert the ISO-8601-formatted date, optionally including time (pass ARG)." - (interactive "P") - (let ((format (if arg "%FT%T%z" "%F"))) - (insert (format-time-string format (current-time))))) - -(defun acdw/kill-a-buffer (&optional prefix) - "Kill this buffer, or other buffers, depending on PREFIX. - -\\[acdw/kill-a-buffer] : Kill CURRENT buffer and window -\\[universal-argument] \\[acdw/kill-a-buffer] : Kill OTHER buffer and window -\\[universal-argument] \\[universal-argument] \\[acdw/kill-a-buffer] : Kill ALL OTHER buffers and windows - -Prompt only if there are unsaved changes." - (interactive "P") - (pcase (or (car prefix) 0) - (0 (kill-current-buffer) - (unless (one-window-p) (delete-window))) - (4 (other-window 1) - (kill-current-buffer) - (unless (one-window-p) (delete-window))) - (16 (mapc 'kill-buffer (delq (current-buffer) (buffer-list))) - (delete-other-windows)))) - -(defun acdw/sunrise-sunset (sunrise-command sunset-command) - "Run SUNRISE-COMMAND at sunrise, and SUNSET-COMMAND at sunset." - (let* ((times-regex (rx (* nonl) - (: (any ?s ?S) "unrise") " " - (group (repeat 1 2 digit) ":" - (repeat 1 2 digit) - (: (any ?a ?A ?p ?P) (any ?m ?M))) - (* nonl) - (: (any ?s ?S) "unset") " " - (group (repeat 1 2 digit) ":" - (repeat 1 2 digit) - (: (any ?a ?A ?p ?P) (any ?m ?M))) - (* nonl))) - (ss (acdw/supress-messages #'sunrise-sunset)) - (_m (string-match times-regex ss)) - (sunrise-time (match-string 1 ss)) - (sunset-time (match-string 2 ss))) - (run-at-time sunrise-time (* 60 60 24) sunrise-command) - (run-at-time sunset-time (* 60 60 24) sunset-command) - (run-at-time "12:00am" (* 60 60 24) sunset-command))) - -(defun acdw/supress-messages (oldfn &rest args) ; from pkal - "Advice wrapper for suppressing `message'. -OLDFN is the wrapped function, that is passed the arguments -ARGS." - (let ((msg (current-message))) - (prog1 - (let ((inhibit-message t)) - (apply oldfn args)) - (when msg - (message "%s" msg))))) - -(defun acdw/setup-fringes () - "Set up fringes how I likes 'em." - (define-fringe-bitmap 'left-curly-arrow - [#b01100000 - #b00110000 - #b00011000 - #b00001100] - 4 8 'center) - (define-fringe-bitmap 'right-curly-arrow - [#b00000011 - #b00000110 - #b00001100 - #b00011000] - 4 8 'center) - (define-fringe-bitmap 'left-arrow - [#b01100000 - #b01010000] - 2 8 '(top t)) - (define-fringe-bitmap 'right-arrow - [#b00000011 - #b00000101] - 2 8 '(top t)) - (setq-local indicate-empty-lines nil - indicate-buffer-boundaries '((top . right) - (bottom . right))) - (custom-set-faces '(fringe - ((t (:foreground "dim gray")))))) - - -;;; Recentf renaming with dired -;; from ... somewhere. 'rjs', apparently? -;; I'm throwing these here because they look better here than in init.el. -;; Comments are "rjs"'s. - -;; Magic advice to rename entries in recentf when moving files in -;; dired. -(defun rjs/recentf-rename-notify (oldname newname &rest _args) - "Magically rename files from OLDNAME to NEWNAME when moved in `dired'." - (if (file-directory-p newname) - (rjs/recentf-rename-directory oldname newname) - (rjs/recentf-rename-file oldname newname))) - -(defun rjs/recentf-rename-file (oldname newname) - "Rename a file from OLDNAME to NEWNAME in `recentf-list'." - (setq recentf-list - (mapcar (lambda (name) - (if (string-equal name oldname) - newname - oldname)) - recentf-list))) - -(defun rjs/recentf-rename-directory (oldname newname) - "Rename directory from OLDNAME to NEWNAME in `recentf-list'." - ;; oldname, newname and all entries of recentf-list should already - ;; be absolute and normalised so I think this can just test whether - ;; oldname is a prefix of the element. - (setq recentf-list - (mapcar (lambda (name) - (if (string-prefix-p oldname name) - (concat newname (substring name (length oldname))) - name)) - recentf-list))) - - -;;; Sort setq... -;; https://emacs.stackexchange.com/questions/33039/ - -(defun sort-setq () - "Sort a setq. Must be a defun." - (interactive) - (save-excursion - (save-restriction - (let ((sort-end (progn (end-of-defun) - (backward-char) - (point-marker))) - (sort-beg (progn (beginning-of-defun) - (re-search-forward "[ \\t]*(" (point-at-eol)) - (forward-sexp) - (re-search-forward "\\_<" (point-at-eol)) - (point-marker)))) - (narrow-to-region (1- sort-beg) (1+ sort-end)) - (sort-subr nil #'sort-setq-next-record #'sort-setq-end-record))))) - -(defun sort-setq-next-record () - "Sort the next record of a `setq' form." - (condition-case nil - (progn - (forward-sexp 1) - (backward-sexp)) - ('scan-error (goto-char (point-max))))) - -(defun sort-setq-end-record () - "Sort the end of a `setq' record." - (condition-case nil - (forward-sexp 2) - ('scan-error (goto-char (point-max))))) - - -;;; Crux tweaks - -;; `crux-other-window-or-switch-buffer' doesn't take an argument. -(defun acdw/other-window-or-switch-buffer (&optional arg) - "Call `other-window' with ARG or switch buffers, depending on window count." - (interactive "P") - (if (one-window-p) - (switch-to-buffer nil) - (other-window (or arg 1)))) - -(defun acdw/other-window-or-switch-buffer-backward () - "Do `acdw/other-window-or-switch-buffer', but backward." - (interactive) - (acdw/other-window-or-switch-buffer -1)) - - -;;; Auth-sources -;; https://github.com/emacs-circe/circe/wiki/Configuration -(defun acdw/fetch-password (&rest params) - "Fetch a password from `auth-source' using PARAMS. -This function is internal. Use `acdw/make-password-fetcher' instead." - (let ((match (car (apply #'auth-source-search params)))) - (if match - (let ((secret (plist-get match :secret))) - (if (functionp secret) - (funcall secret) - secret)) - (message "Password not found for %S" params)))) - -(defun acdw/make-password-fetcher (&rest params) - "Make a function that will call `acdw/fetch-password' with PARAMS." - (lambda (&rest _) - (apply #'acdw/fetch-password params))) - - -;;; Paren annoyances -(defun acdw/stop-paren-annoyances (&optional buffer) - "Locally turn off paren-checking functions in BUFFER." - (with-current-buffer (or buffer (current-buffer)) - (setq-local blink-matching-paren nil - show-paren-mode nil))) - - -;;; 💩 -(defun 💩 (&optional n) - "💩 x N." - (interactive "p") - (let ((n (or n 1))) - (while (> n 0) - (insert "💩") - (setq n (1- n))))) - - -;;; Fat finger solutions -(defun acdw/fat-finger-exit (&optional prefix) - "Delete a frame, or kill Emacs with confirmation. -When called with PREFIX, just kill Emacs without confirmation." - (interactive "P") - (if (or prefix - (and (= 1 (length (frame-list))) - (yes-or-no-p "This is the last frame! Wanna quit?"))) - (kill-emacs) - (ignore-errors - (delete-frame)))) - -(defun acdw/disabled-command-function (&optional cmd keys) - (let ((cmd (or cmd this-command)) - (keys (or keys (this-command-keys)))) - ;; this logic stolen from original `disabled-command-function' - (if (or (eq (aref keys 0) (if (stringp keys) - (aref "\M-x" 0) - ?\M-x)) - (and (>= (length keys) 2) - (eq (aref keys 0) meta-prefix-char) - (eq (aref keys 1) ?x))) - ;; it's been run as an M-x command, we want to do it - (call-interactively cmd) - ;; else, tell the user it's disabled. - (message (substitute-command-keys - (concat "Command `%s' has been disabled. " - "Run with \\[execute-extended-command].")) - cmd)))) - - -;;; cribbed - -;; https://jao.io/blog/2021-09-08-high-signal-to-noise-emacs-command.html -(defun jao-buffer-same-mode (&rest modes) - "Pop to a buffer with a mode among MODES, or the current one if not given." - (interactive) - (let* ((modes (or modes (list major-mode))) - (pred (lambda (b) - (let ((b (get-buffer (if (consp b) (car b) b)))) - (member (buffer-local-value 'major-mode b) modes))))) - (pop-to-buffer (read-buffer "Buffer: " nil t pred)))) - -;;; BLAH - -(defun open-paragraph () - "Open a paragraph after point. -A paragraph is defined as continguous non-empty lines of text -surrounded by empty lines, so opening a paragraph means to make -three blank lines, then place the point on the second one." - (interactive) - ;; Go to next blank line. This /isn't/ `end-of-paragraph-text' because - ;; that's weird with org, and I'm guessing other modes too. - (while (not (looking-at "^$")) - (forward-line 1)) - (newline) - (delete-blank-lines) - (newline 2) - (forward-line -1)) +;;; Code: -(defun require/ (feature &optional filename noerror) - "If FEATURE is not loaded, load it from FILENAME. -This function works just like `require', with one crucial -difference: if the FEATURE name contains a slash, the FILENAME -will as well -- unless, of course, FILENAME is set. This allows -for `require/' to require files within subdirectories of -directories of `load-path'. Of course, NOERROR isn't affected by -the change." - (let* ((feature-name (if (symbolp feature) - (symbol-name feature) - feature)) - (filename (or filename - (and (string-match-p "/" feature-name) - feature-name)))) - (require (intern feature-name) filename noerror))) +;;; Define a directory and an expanding function + +(defmacro +define-dir (name directory &optional docstring inhibit-mkdir) + "Define a variable and function NAME expanding to DIRECTORY. +DOCSTRING is applied to the variable. Ensure DIRECTORY exists in +the filesystem, unless INHIBIT-MKDIR is non-nil." + (declare (indent 2)) + (unless inhibit-mkdir + (make-directory (eval directory) :parents)) + `(progn + (defvar ,name ,directory + ,(concat docstring (when docstring "\n") + "Defined by `/define-dir'.")) + (defun ,name (file &optional mkdir) + ,(concat "Expand FILE relative to variable `" (symbol-name name) "'.\n" + "If MKDIR is non-nil, the directory is created.\n" + "Defined by `/define-dir'.") + (let ((file-name (expand-file-name (convert-standard-filename file) + ,name))) + (when mkdir + (make-directory (file-name-directory file-name) :parents)) + file-name)))) (provide 'acdw) ;;; acdw.el ends here diff --git a/lisp/chd.el b/lisp/chd.el deleted file mode 100644 index c6efad0..0000000 --- a/lisp/chd.el +++ /dev/null @@ -1,76 +0,0 @@ -;;; chd.el --- CHD customizations -*- lexical-binding: t -*- - -(require 'acdw-org) -(require 'org) - -(defvar chd/dir (acdw/sync-dir "Click Here Digital/") - "Where Click Here stuff is stored.") - -(defun chd/dir (file &optional make-directory) - "Expand FILE relative to variable `chd/dir'. -If MAKE-DIRECTORY is non-nil, ensure the file's -containing directory exists." - (let ((file-name (expand-file-name (convert-standard-filename file) - chd/dir))) - (when make-directory - (make-directory (file-name-directory file-name) :parents)) - file-name)) - -(defun chd/narrow-to-task (&optional point) - "Narrow the buffer to the task POINT is in." - (interactive "d") - (when point (goto-char point)) - (if (called-interactively-p 'interactive) - (save-excursion - (while (not (org-entry-is-todo-p)) - (acdw/org-previous-heading-widen 1)) - (org-narrow-to-subtree)) - ;; well this is dumb... - (while (not (org-entry-is-todo-p)) - (acdw/org-previous-heading-widen 1)) - (org-narrow-to-subtree))) - -(defun chd/clock-in () - "Clock in to the current task." - (save-excursion - (chd/narrow-to-task) - (org-clock-in))) - -(defun chd/do-the-thing () - "Copy the plain version of the current task and open its link." - (interactive) - (chd/narrow-to-task) - (save-excursion - ;; Prepare buffer - (acdw/flyspell-correct-f7) ; This is defined... elsewhere. - - ;; Export the buffer and copy it - (pcase (org-entry-get (point-min) "EXPORTAS" t) - ("html" (acdw/org-export-copy-html)) - (_ (acdw/org-export-copy))) - - ;; Open the link to the doc - (org-back-to-heading) - (org-open-at-point))) - -(defun chd/insert-client () - "Insert the current client at point." - (interactive) - (if-let ((client (org-entry-get nil "CLIENT" :inherit))) - (insert client) - (beep) - (user-error "No client found in current subtree"))) - -;;; Click Bits! -(require 'acdw-autoinsert) -(require 'acdw) -(require 'private (acdw/sync-dir "private")) -(acdw/define-auto-insert '(:replace t) - (cons (chd/dir "Click Bits" t) "Click Bits!") - chd/click-bits-skeleton) - -;;; NOTES -;; org-protocol: https://orgmode.org/worg/org-contrib/org-protocol.html -;; the bit i wanna pull from TaskIQ: 'document.getElementById("preview") -(provide 'chd) -;;; chd.el ends here diff --git a/lisp/titlecase.el b/lisp/titlecase.el deleted file mode 100644 index 64da5b4..0000000 --- a/lisp/titlecase.el +++ /dev/null @@ -1,157 +0,0 @@ -;;; titlecase.el -*- lexical-binding: t; -*- - -;; https://hungyi.net/posts/programmers-way-to-title-case/ - -(require 'cl-lib) -(require 'subr-x) - -;;;###autoload -(defun titlecase-string (str) - "Convert string STR to title case and return the resulting string." - (let* ((case-fold-search nil) - (str-length (length str)) - ;; A list of markers that indicate start of a new phrase within the - ;; title, e.g. "The Lonely Reindeer: A Christmas Story" - ;; must be followed by one of word-boundary-chars - (new-phrase-chars '(?: ?. ?? ?\; ?\n ?\r)) - ;; immediately triggers new phrase behavior without waiting for word - ;; boundary - (immediate-new-phrase-chars '(?\n ?\r)) - ;; A list of characters that indicate "word boundaries"; used to split - ;; the title into processable segments - (word-boundary-chars (append '(? ?– ?— ?- ?‑ ?/) - immediate-new-phrase-chars)) - ;; A list of small words that should not be capitalized (in the right - ;; conditions) - (small-words '("a" "an" "and" "as" "at" "but" "by" "en" "for" "if" - "in" "of" "on" "or" "the" "to" "v" "v." "vs" "vs." - "via")) - ;; Fix if str is ALL CAPS - (str (if (string-match-p "[a-z]" str) str (downcase str))) - ;; Reduce over a state machine to do title casing - (final-state - (cl-reduce - (lambda (state char) - (let* ((result (aref state 0)) - (last-segment (aref state 1)) - (first-word-p (aref state 2)) - (was-in-path-p (aref state 3)) - (last-char (car last-segment)) - (in-path-p (or (and (eq char ?/) - (or (not last-segment) - (member last-char '(?. ?~)))) - (and was-in-path-p - (not - (or (eq char ? ) - (member - char - immediate-new-phrase-chars)))))) - (end-p - ;; are we at the end of the input string? - (eq (+ (length result) (length last-segment) 1) - str-length)) - (pop-p - ;; do we need to pop a segment onto the output result? - (or end-p (and (not in-path-p) - (member char word-boundary-chars)))) - (segment - ;; add the current char to the current segment - (cons char last-segment)) - (segment-string - ;; the readable version of the segment - (apply #'string (reverse segment))) - (small-word-p - ;; was the last segment a small word? - (member (downcase (substring segment-string 0 -1)) - small-words)) - (capitalize-p - ;; do we need to capitalized this segment or lowercase it? - (or end-p first-word-p (not small-word-p))) - (ignore-segment-p - ;; ignore explicitly capitalized segments - (or (string-match-p "[a-zA-Z].*[A-Z]" segment-string) - ;; ignore URLs - (string-match-p "^https?:" segment-string) - ;; ignore hostnames and namespaces.like.this - (string-match-p "\\w\\.\\w" segment-string) - ;; ignore windows filesystem paths - (string-match-p "^[A-Za-z]:\\\\" segment-string) - ;; ignore unix filesystem paths - was-in-path-p - ;; ignore email addresses and user handles with @ symbol - (member ?@ segment))) - (next-result - (if pop-p - (concat result - (if ignore-segment-p - ;; pop segment onto the result without - ;; processing - segment-string - ;; titlecase the segment before popping onto - ;; result - (titlecase--segment - segment-string capitalize-p))) - result)) - (next-segment - (unless pop-p segment)) - (will-be-first-word-p - (if pop-p - (or (not last-segment) - (member last-char new-phrase-chars) - (member char immediate-new-phrase-chars)) - first-word-p))) - (vector - next-result next-segment will-be-first-word-p in-path-p))) - str - :initial-value - (vector nil ; result stack - nil ; current working segment - t ; is it the first word of a phrase? - nil)))) ; are we inside of a filesystem path? - (aref final-state 0))) - -(defun titlecase--segment (segment capitalize-p) - "Convert a title's inner SEGMENT to capitalized or lower case -depending on CAPITALIZE-P, then return the result." - (let* ((case-fold-search nil) - (ignore-chars '(?' ?\" ?\( ?\[ ?‘ ?“ ?’ ?” ?_)) - (final-state - (cl-reduce - (lambda (state char) - (let ((result (aref state 0)) - (downcase-p (aref state 1))) - (cond - (downcase-p - ;; already upcased start of segment, so lowercase the rest - (vector (cons (downcase char) result) t)) - ((member char ignore-chars) - ;; check if start char of segment needs to be ignored - (vector (cons char result) downcase-p)) - (t - ;; haven't upcased yet, and we can, so do it - (vector (cons (upcase char) result) t))))) - segment - :initial-value (vector nil (not capitalize-p))))) - (thread-last (aref final-state 0) - (reverse) - (apply #'string)))) - -;;;###autoload -(defun titlecase-region (begin end) - "Convert text in region from BEGIN to END to title case." - (interactive "*r") - (let ((pt (point))) - (insert (titlecase-string (delete-and-extract-region begin end))) - (goto-char pt))) - -;;;###autoload -(defun titlecase-dwim () - "Convert the region or current line to title case. -If Transient Mark Mode is on and there is an active region, convert -the region to title case. Otherwise, work on the current line." - (interactive) - (if (and transient-mark-mode mark-active) - (titlecase-region (region-beginning) (region-end)) - (titlecase-region (point-at-bol) (point-at-eol)))) - -(provide 'titlecase) -- cgit 1.4.1-21-gabe81