diff options
Diffstat (limited to 'lisp')
-rw-r--r-- | lisp/+browse-url.el | 189 | ||||
-rw-r--r-- | lisp/+cape.el | 25 | ||||
-rw-r--r-- | lisp/+custom.el | 52 | ||||
-rw-r--r-- | lisp/+emacs.el | 422 | ||||
-rw-r--r-- | lisp/+emms.el | 38 | ||||
-rw-r--r-- | lisp/+hungry-delete.el | 53 | ||||
-rw-r--r-- | lisp/+isearch.el | 24 | ||||
-rw-r--r-- | lisp/+notmuch.el | 52 | ||||
-rw-r--r-- | lisp/+org-capture.el | 197 | ||||
-rw-r--r-- | lisp/+org.el | 268 | ||||
-rw-r--r-- | lisp/+ox.el | 29 | ||||
-rw-r--r-- | lisp/+paredit.el | 26 | ||||
-rw-r--r-- | lisp/+tempo.el | 45 | ||||
-rw-r--r-- | lisp/+titlecase.el | 6 | ||||
-rw-r--r-- | lisp/+window.el | 130 | ||||
-rw-r--r-- | lisp/acdw-defaults.el | 292 | ||||
-rw-r--r-- | lisp/acdw-funs.el | 262 | ||||
-rw-r--r-- | lisp/acdw-macs.el | 293 | ||||
-rw-r--r-- | lisp/acdw.el | 345 | ||||
-rw-r--r-- | lisp/browse-url-transform.el | 45 | ||||
-rw-r--r-- | lisp/dawn.el | 109 | ||||
-rw-r--r-- | lisp/def.el | 142 | ||||
-rw-r--r-- | lisp/graveyard.el | 50 | ||||
-rw-r--r-- | lisp/init-org.el | 144 | ||||
-rw-r--r-- | lisp/org-word-count.el | 297 | ||||
-rw-r--r-- | lisp/pita.el | 69 | ||||
-rw-r--r-- | lisp/private.el | 23 | ||||
-rw-r--r-- | lisp/scule.el | 61 | ||||
-rw-r--r-- | lisp/upload-junk.el | 47 | ||||
-rw-r--r-- | lisp/yoke.el | 664 |
30 files changed, 2075 insertions, 2324 deletions
diff --git a/lisp/+browse-url.el b/lisp/+browse-url.el index 12e433c..b65b6f9 100644 --- a/lisp/+browse-url.el +++ b/lisp/+browse-url.el | |||
@@ -1,60 +1,101 @@ | |||
1 | ;;; +browse-url.el -*- lexical-binding: t -*- | 1 | ;;; +browse-url.el -*- lexical-binding: t; -*- |
2 | 2 | ||
3 | (require 'browse-url) | 3 | (require 'browse-url) |
4 | (require 'cl-lib) | ||
5 | (require 'seq) | ||
6 | (require 'url-util) | ||
7 | |||
8 | (defgroup +browse-url nil | ||
9 | "My `browse-url' extras." | ||
10 | :group 'browse-url) | ||
11 | |||
12 | ;;; External URL handlers | ||
4 | 13 | ||
5 | (cl-defmacro +browse-url-make-external-viewer-handler | 14 | (cl-defmacro +browse-url-make-external-viewer-handler |
6 | (viewer default-args | 15 | (viewer |
7 | &optional (prompt "URL: ") | 16 | &key |
8 | &key | 17 | args |
9 | (custom-group 'browse-url) | 18 | (prompt "URL: ") |
10 | (name (intern (format "+browse-url-with-%s" viewer))) | 19 | (program (executable-find (format "%s" viewer))) |
11 | doc vardoc | 20 | (name (intern (format "+browse-url-with-%s" viewer))) |
12 | (varname (intern (format "%s-args" name))) | 21 | doc |
13 | (fallback t)) | 22 | (var (intern (format "%s-args" name))) |
14 | "Create a `browse-url' handler function calling VIEWER on the url. | 23 | vardoc |
24 | (custom-group '+browse-url) | ||
25 | (fallback '(function browse-url-generic))) | ||
26 | "Create a `browse-url' handler function calling PROGRAM on the URL. | ||
15 | This macro also creates a `customize' setting in CUSTOM-GROUP for | 27 | This macro also creates a `customize' setting in CUSTOM-GROUP for |
16 | VIEWER's command-line arguments. DEFAULT-ARGS specifies the | 28 | PROGRAM's command-line arguments. ARGS specifies the |
17 | default arguments for that setting. | 29 | default arguments for this user option. |
30 | |||
31 | PROGRAM defaults to the result of calling `executable-find' on VIEWER. | ||
18 | 32 | ||
19 | PROMPT is shown to the user in the function's `interactive' spec, | 33 | PROMPT is shown to the user in the function's `interactive' spec, as an argument |
20 | as an argument to `browse-url-interactive-arg'. | 34 | to `browse-url-interactive-arg'. |
21 | 35 | ||
22 | The resulting function is named NAME, which defaults to | 36 | The resulting function is named NAME, which defaults to |
23 | `+browse-url-wth-VIEWER'. The custom variable is named VARNAME, | 37 | `+browse-url-with-VIEWER'. The custom variable is named VAR, which defaults |
24 | which defaults to `NAME-args'. If DOC or VARDOC are provided, | 38 | to `NAME-args'. If DOC or VARDOC are provided, they'll be the documentation of |
25 | they'll be the documentation of the function and variable | 39 | the function and variable respectively; otherwise a basic default doc-string is |
26 | respectively; otherwise, basic docstrings are used. | 40 | used. |
27 | 41 | ||
28 | Finally, if FALLBACK is non-nil (by default, it's | 42 | If FALLBACK is non-nil (the default is `browse-url-generic'), the |
29 | `browse-url-generic'), the function will call that if unable to | 43 | generated function will call FALLBACK if unable to start PROGRAM |
30 | start VIEWER." | 44 | for some reason." |
31 | (declare (indent 1)) | 45 | (declare (indent 1)) |
32 | `(progn | 46 | `(progn |
33 | (defcustom ,varname ,default-args | 47 | (defcustom ,var ,args |
34 | ,(or doc (format "Arguments to pass to %s in `%s'." viewer name)) | 48 | ,(or vardoc (format "Arguments to pass to %s in `%s'." |
49 | viewer name)) | ||
35 | :type '(repeat :tag "Command-line argument" string) | 50 | :type '(repeat :tag "Command-line argument" string) |
36 | :group ',custom-group) | 51 | :group ',custom-group) |
37 | (defun ,name (url &optional new-window) | 52 | (defun ,name (url &optional new-window) |
38 | ,(or vardoc (format "Open URL in %s." viewer)) | 53 | ,(or doc (format "Open URL in %s." viewer)) |
39 | (interactive (browse-url-interactive-arg ,prompt)) | 54 | (interactive (browse-url-interactive-arg ,prompt)) |
40 | (let* ((url (browse-url-encode-url url)) | 55 | (let* ((url (browse-url-encode-url url)) |
41 | (process-environment (browse-url-process-environment))) | 56 | (process-environment (browse-url-process-environment))) |
42 | (message ,(format "Opening %%s in %s..." viewer) url) | 57 | (message ,(format "Opening %%s in %s..." viewer) url) |
43 | (unless (ignore-errors (apply #'start-process | 58 | (unless (ignore-errors (apply #'start-process |
44 | (format "%s %s" ,viewer url) nil | 59 | (format "%s %s" ',viewer url) |
45 | ,viewer | 60 | nil |
46 | (append ,varname (list url)))) | 61 | ,program |
62 | (append ,var (list url)))) | ||
47 | ,@(cond | 63 | ,@(cond |
48 | ((eq fallback t) '((browse-url-generic url new-window))) | ||
49 | (fallback `((funcall ,fallback url new-window))) | 64 | (fallback `((funcall ,fallback url new-window))) |
50 | (:else `((message "Can't find viewer: `%s'" ,viewer) | 65 | (:else `((message "Can't find viewer: %s" ,viewer) |
51 | nil)))))))) | 66 | nil)))))))) |
52 | 67 | ||
68 | ;; Some default handlers | ||
69 | |||
70 | (+browse-url-make-external-viewer-handler mpv | ||
71 | :args '("--cache-pause-wait=15" | ||
72 | "--cache-pause-initial=yes") | ||
73 | :prompt "Video URL: ") | ||
74 | |||
75 | (+browse-url-make-external-viewer-handler mpv-image | ||
76 | :program (executable-find "mpv") | ||
77 | :args '("--image-display-duration=inf") | ||
78 | :prompt "Image URL: ") | ||
79 | |||
80 | ;;; Downloading | ||
81 | |||
53 | (defcustom +browse-url-download-open t | 82 | (defcustom +browse-url-download-open t |
54 | "Whether to open downloaded files afterward." | 83 | "Whether to open downloaded files after downloading." |
55 | :group 'browse-url | ||
56 | :type 'boolean) | 84 | :type 'boolean) |
57 | 85 | ||
86 | (defun +browse-url-download (url &rest _) | ||
87 | "Download URL to `eww-download-directory'." | ||
88 | (interactive "sDownload URL: ") | ||
89 | (let ((dir eww-download-directory)) | ||
90 | (when (functionp dir) (setq dir (funcall dir))) | ||
91 | (make-directory dir :parents) | ||
92 | (url-retrieve url | ||
93 | (lambda (s u d) | ||
94 | (let ((file (+browse-url-download-callback s u d))) | ||
95 | (when +browse-url-download-open | ||
96 | (browse-url-xdg-open file)))) | ||
97 | (list url dir)))) | ||
98 | |||
58 | (defun +browse-url-download-callback (status url dir) | 99 | (defun +browse-url-download-callback (status url dir) |
59 | ;; A slight change to `eww-download-callback' that returns the downloaded | 100 | ;; A slight change to `eww-download-callback' that returns the downloaded |
60 | ;; filename. | 101 | ;; filename. |
@@ -71,18 +112,78 @@ start VIEWER." | |||
71 | (message "Saved %s" file) | 112 | (message "Saved %s" file) |
72 | file))) | 113 | file))) |
73 | 114 | ||
74 | (defun +browse-url-download (url &rest _) | 115 | ;;; URL matcher generators |
75 | "Download URL to `eww-download-directory'." | 116 | |
76 | (interactive "sDownload URL: ") | 117 | (defun +browse-url-matches (&rest regexps) |
77 | (let ((dir eww-download-directory)) | 118 | "Return a lambda that will determine if a url matches REGEXPS. |
78 | (when (functionp dir) (setq dir (funcall dir))) | 119 | Each regexp will be tested in turn. The first one that matches |
79 | (make-directory dir :parents) | 120 | is returned by the lambda. |
80 | (url-retrieve url | 121 | |
81 | (lambda (s u d) | 122 | This is a good function to use in key positions in `browse-url-handlers'." |
82 | (let ((file (+browse-url-download-callback s u d))) | 123 | `(lambda (url &optional new-window) |
83 | (when +browse-url-download-open | 124 | (cl-loop for regexp in ',regexps |
84 | (browse-url-xdg-open file)))) | 125 | if (string-match-p regexp url) |
85 | (list url dir)))) | 126 | return regexp))) |
127 | |||
128 | ;;; External domains | ||
129 | ;; Some domains just don't open well in `eww'. The following function and user | ||
130 | ;; option define an easy way to automatically open those. | ||
131 | |||
132 | (defcustom +browse-url-external-domains nil | ||
133 | "Domains to open in `browse-url-secondary-browser-function'. | ||
134 | This is just a list of strings. They'll be regexp-escaped and | ||
135 | passed to `+browse-url-external-url-p', which is a good function | ||
136 | to put in `browse-url-handlers'. | ||
137 | |||
138 | If an item in this list is a list itself, it should contain one string, a valid | ||
139 | regexp that will not be regexp-quoted when matching against a url." | ||
140 | :type '(repeat (choice | ||
141 | (list :tag "Regexp" regexp) | ||
142 | (string :tag "Literal string")))) | ||
143 | |||
144 | (defun +browse-url-external-url-p (url) | ||
145 | "Return t if URL is a member of `+browse-url-external-domains'. | ||
146 | This function only tests URL's domain." | ||
147 | (let ((host (url-host (url-generic-parse-url url)))) | ||
148 | (cl-loop for domain in +browse-url-external-domains | ||
149 | if (string-match-p (if (stringp domain) | ||
150 | (regexp-quote domain) | ||
151 | (car domain)) | ||
152 | host) | ||
153 | return t))) | ||
154 | |||
155 | ;;; Switch to an external browser from an Emacs browser | ||
156 | |||
157 | (defmacro +browse-url-switch-external-browser (mode url-fetcher-form) | ||
158 | "Create a function for MODE to open an external browser. | ||
159 | URL-FETCHER-FORM will be used to get the URL of the current visited page." | ||
160 | (declare (indent 1)) | ||
161 | `(defun ,(intern (format "+browse-url-external-from-%s" mode)) | ||
162 | (&optional url) | ||
163 | "Browse URL with `browse-url-secondary-browser-function'. | ||
164 | This will close the current buffer." | ||
165 | (interactive nil ,mode) | ||
166 | (condition-case e | ||
167 | (funcall browse-url-secondary-browser-function | ||
168 | (or url ,url-fetcher-form)) | ||
169 | (:success (when (null url) (quit-window))) ; Interactive use | ||
170 | (t (signal (car e) (cdr e)))))) | ||
171 | |||
172 | ;;; Mark `browse-url-browser-function' as safe | ||
173 | |||
174 | (defcustom +browse-url-other-safe-browser-functions nil | ||
175 | "Other safe browser functions." | ||
176 | :type '(repeat function)) | ||
177 | |||
178 | (defun +browse-url-browser-function-safe-p (f) | ||
179 | "Return t if F is a safe browser function." | ||
180 | (memq f (append +browse-url-other-safe-browser-functions | ||
181 | (mapcar (lambda (i) | ||
182 | (plist-get (cdr i) :value)) | ||
183 | (seq-filter (lambda (i) | ||
184 | (eq (car i) 'function-item)) | ||
185 | (cdr (get 'browse-url-browser-function | ||
186 | 'custom-type))))))) | ||
86 | 187 | ||
87 | (provide '+browse-url) | 188 | (provide '+browse-url) |
88 | ;;; +browse-url.el ends here | 189 | ;;; +browse-url.el ends here |
diff --git a/lisp/+cape.el b/lisp/+cape.el new file mode 100644 index 0000000..37e88fe --- /dev/null +++ b/lisp/+cape.el | |||
@@ -0,0 +1,25 @@ | |||
1 | ;;; cape.el -*- lexical-binding: t; -*- | ||
2 | |||
3 | ;;; Code: | ||
4 | |||
5 | (require 'cape) | ||
6 | |||
7 | (defmacro +cape-insinuate (hook capes &rest capfs) | ||
8 | "Insinuate CAPES for a mode. | ||
9 | Add a function to HOOK that will add CAPES to the local | ||
10 | `completion-at-point-functions' for that mode's buffer. If CAPFS | ||
11 | are given, mark them all as non-exclusive." | ||
12 | (let ((fn (intern (format "+cape-insinuate@%s" hook)))) | ||
13 | `(prog1 | ||
14 | ,@(when capes | ||
15 | `((defun ,fn () | ||
16 | ,@(cl-loop for cape in capes | ||
17 | collect `(add-hook 'completion-at-point-functions | ||
18 | #',cape 90 :local))) | ||
19 | (add-hook ',hook #',fn))) | ||
20 | ,@(cl-loop for capf in capfs | ||
21 | collect `(advice-add ',capf :around | ||
22 | #'cape-wrap-nonexclusive))))) | ||
23 | |||
24 | (provide '+cape) | ||
25 | ;;; +cape.el ends here | ||
diff --git a/lisp/+custom.el b/lisp/+custom.el deleted file mode 100644 index ba4c55d..0000000 --- a/lisp/+custom.el +++ /dev/null | |||
@@ -1,52 +0,0 @@ | |||
1 | ;;; +custom.el -*- lexical-binding: t -*- | ||
2 | |||
3 | (require 'cl-lib) | ||
4 | (require 'seq) | ||
5 | |||
6 | (defgroup +custom nil | ||
7 | "Group for extra `customize' customizations." | ||
8 | :group 'customize) | ||
9 | |||
10 | (defcustom +custom-allowed-variables nil | ||
11 | "Variables to load during `+custom-load-some-customizations'." | ||
12 | :type '(repeat symbol)) | ||
13 | |||
14 | (defcustom +custom-allowed-faces nil | ||
15 | "Faces to load during `+custom-load-some-customziations'." | ||
16 | :type '(repeat face)) | ||
17 | |||
18 | (defun +custom--filter-list (customlist allowlist) | ||
19 | "Filter CUSTOMLIST to only include those items in ALLOWLIST. | ||
20 | Each item in ALLOWLIST will be compared using `eq' to the `car' | ||
21 | of each item in CUSTOMLIST. Items in CUSTOMLIST not included in | ||
22 | ALLOWLIST will be removed from the return value." | ||
23 | (seq-filter (lambda (el) (memq (car el) allowlist)) | ||
24 | customlist)) | ||
25 | |||
26 | (defcustom +custom-after-load-hook nil | ||
27 | "Hook run after loading the custom file." | ||
28 | :type 'hook) | ||
29 | |||
30 | (defun +custom-load-some-customizations (&optional noerror | ||
31 | nomessage | ||
32 | nosuffix | ||
33 | must-suffix) | ||
34 | "Load `custom-file', ignoring most customizations. | ||
35 | Only faces included in `+custom-allowed-faces' and variables | ||
36 | included in `+custom-allowed-variables' will be loaded. | ||
37 | |||
38 | All optional arguments---NOERROR, NOMESSAGE, NOSUFFIX, | ||
39 | MUST-SUFFIX---are passed to `load', which see." | ||
40 | (cl-letf (((symbol-function 'custom-set-faces) | ||
41 | (lambda (&rest args) | ||
42 | (apply #'custom-theme-set-faces 'user | ||
43 | (+custom--filter-list args +custom-allowed-faces)))) | ||
44 | ((symbol-function 'custom-set-variables) | ||
45 | (lambda (&rest args) | ||
46 | (apply #'custom-theme-set-variables 'user | ||
47 | (+custom--filter-list args +custom-allowed-variables))))) | ||
48 | (load custom-file noerror nomessage nosuffix must-suffix)) | ||
49 | (run-hooks '+custom-after-load-hook)) | ||
50 | |||
51 | (provide '+custom) | ||
52 | ;;; +custom.el ends here | ||
diff --git a/lisp/+emacs.el b/lisp/+emacs.el deleted file mode 100644 index 97377a3..0000000 --- a/lisp/+emacs.el +++ /dev/null | |||
@@ -1,422 +0,0 @@ | |||
1 | ;;; +emacs.el --- measured defaults for Emacs -*- lexical-binding: t -*- | ||
2 | |||
3 | ;;; Commentary: | ||
4 | |||
5 | ;; I find myself copy-pasting a lot of "boilerplate" type code when | ||
6 | ;; bankrupting my Emacs config and starting afresh. Instead of doing | ||
7 | ;; that, I'm putting it here, where it'll be easier to include in my | ||
8 | ;; config. | ||
9 | |||
10 | ;; Of course, some might say I could just ... stop bankrupting my | ||
11 | ;; Emacs. But like, why would I want to? | ||
12 | |||
13 | ;; Other notable packages include | ||
14 | ;; - https://git.sr.ht/~technomancy/better-defaults/ | ||
15 | ;; - https://github.com/susam/emfy | ||
16 | |||
17 | ;;; Code: | ||
18 | |||
19 | (require 'early-init (locate-user-emacs-file "early-init.el")) | ||
20 | |||
21 | (defun +set-major-mode-from-buffer-name (&optional buf) | ||
22 | "Set the major mode for BUF from the buffer's name. | ||
23 | Do this only if the buffer is not visiting a file." | ||
24 | (unless buffer-file-name | ||
25 | (let ((buffer-file-name (buffer-name buf))) | ||
26 | (set-auto-mode)))) | ||
27 | |||
28 | |||
29 | ;;; General settings | ||
30 | |||
31 | (setq-default | ||
32 | apropos-do-all t | ||
33 | async-shell-command-buffer 'new-buffer | ||
34 | async-shell-command-display-buffer nil | ||
35 | auto-hscroll-mode 'current-line | ||
36 | auto-revert-verbose t | ||
37 | auto-save-default nil | ||
38 | auto-save-file-name-transforms `((".*" ,(.etc "auto-save/") ,(car (secure-hash-algorithms))) | ||
39 | (".*" ,(.etc "auto-save/") t)) | ||
40 | auto-save-interval 30 | ||
41 | auto-save-list-file-prefix (.etc "auto-save/.saves-" t) | ||
42 | auto-save-timeout 30 | ||
43 | auto-save-visited-interval 5 | ||
44 | auto-window-vscroll nil | ||
45 | backup-by-copying t | ||
46 | backup-directory-alist `((".*" . ,(.etc "backup/" t))) | ||
47 | blink-cursor-blinks 1 | ||
48 | comp-deferred-compilation nil | ||
49 | completion-category-defaults nil | ||
50 | completion-category-overrides '((file (styles . (partial-completion)))) | ||
51 | completion-ignore-case t | ||
52 | completion-styles '(substring partial-completion) | ||
53 | create-lockfiles nil | ||
54 | cursor-in-non-selected-windows 'hollow | ||
55 | cursor-type 'bar | ||
56 | custom-file (.etc "custom.el") | ||
57 | delete-old-versions t | ||
58 | echo-keystrokces 0.1 | ||
59 | ediff-window-setup-function 'ediff-setup-windows-plain | ||
60 | eldoc-echo-area-use-multiline-p nil | ||
61 | eldoc-idle-delay 0.1 | ||
62 | enable-recursive-minibuffers t | ||
63 | executable-prefix-env t | ||
64 | fast-but-imprecise-scrolling t | ||
65 | file-name-shadow-properties '(invisible t intangible t) | ||
66 | fill-column 80 | ||
67 | find-file-visit-truename t | ||
68 | frame-resize-pixelwise t | ||
69 | global-auto-revert-non-file-buffers t | ||
70 | global-mark-ring-max 100 | ||
71 | hscroll-margin 1 | ||
72 | hscroll-step 1 | ||
73 | imenu-auto-rescan t | ||
74 | image-use-external-converter (or (executable-find "convert") | ||
75 | (executable-find "gm") | ||
76 | (executable-find "ffmpeg")) | ||
77 | indent-tabs-mode nil | ||
78 | inhibit-startup-screen t | ||
79 | initial-buffer-choice t | ||
80 | kept-new-versions 6 | ||
81 | kept-old-versions 2 | ||
82 | kill-do-not-save-duplicates t | ||
83 | kill-read-only-ok t | ||
84 | kill-ring-max 500 | ||
85 | kmacro-ring-max 20 | ||
86 | load-prefer-newer noninteractive | ||
87 | major-mode '+set-major-mode-from-buffer-name | ||
88 | mark-ring-max 50 | ||
89 | minibuffer-eldef-shorten-default t | ||
90 | minibuffer-prompt-properties (list 'read-only t | ||
91 | 'cursor-intangible t | ||
92 | 'face 'minibuffer-prompt) | ||
93 | mode-require-final-newline 'visit-save | ||
94 | mouse-drag-copy-region t | ||
95 | mouse-wheel-progressive-speed nil | ||
96 | mouse-yank-at-point t | ||
97 | native-comp-async-report-warnings-errors 'silent | ||
98 | native-comp-deferred-compilation nil | ||
99 | read-answer-short t | ||
100 | read-buffer-completion-ignore-case t | ||
101 | ;; read-extended-command-predicate | ||
102 | ;; (when (fboundp | ||
103 | ;; 'command-completion-default-include-p) | ||
104 | ;; 'command-completion-default-include-p) | ||
105 | read-process-output-max 1048576 ; We’re in the future man. Set that to at least a megabyte | ||
106 | recenter-positions '(top 2 middle bottom) | ||
107 | regexp-search-ring-max 100 | ||
108 | regexp-search-ring-max 200 | ||
109 | save-interprogram-paste-before-kill t | ||
110 | save-some-buffers-default-predicate #'+save-some-buffers-p | ||
111 | scroll-conservatively 25 | ||
112 | scroll-margin 0 | ||
113 | scroll-preserve-screen-position 1 | ||
114 | scroll-step 1 | ||
115 | search-ring-max 200 | ||
116 | search-ring-max 200 | ||
117 | sentence-end-double-space t | ||
118 | set-mark-command-repeat-pop t | ||
119 | show-paren-delay 0 | ||
120 | show-paren-style 'parenthesis | ||
121 | show-paren-when-point-in-periphery t | ||
122 | show-paren-when-point-inside-paren t | ||
123 | ;;show-trailing-whitespace t | ||
124 | tab-bar-show 1 | ||
125 | tab-width 8 ; so alignment expecting the default looks right | ||
126 | tramp-backup-directory-alist backup-directory-alist | ||
127 | undo-limit 100000000 ; 10 MB | ||
128 | use-dialog-box nil | ||
129 | use-file-dialog nil | ||
130 | use-short-answers t | ||
131 | vc-follow-symlinks t | ||
132 | vc-make-backup-files t | ||
133 | version-control t | ||
134 | view-read-only t | ||
135 | visible-bell nil | ||
136 | window-resize-pixelwise t | ||
137 | x-select-enable-clipboard t | ||
138 | x-select-enable-primary t | ||
139 | yank-pop-change-selection t | ||
140 | ) | ||
141 | |||
142 | ;; Programming language offsets. | ||
143 | ;; Set these after the initial block so I can use `tab-width' | ||
144 | (setq-default | ||
145 | c-basic-offset tab-width) | ||
146 | |||
147 | ;; Emacs 28 ships with an option, `use-short-answers', that makes this form | ||
148 | ;; obsolete, but I still use 27 at work. | ||
149 | (when (version< emacs-version "28") | ||
150 | (fset 'yes-or-no-p 'y-or-n-p)) | ||
151 | |||
152 | |||
153 | ;;; Encodings | ||
154 | |||
155 | ;; Allegedly, this is the only one you need... | ||
156 | (set-language-environment "UTF-8") | ||
157 | ;; But I still set all of these, for fun. | ||
158 | (setq-default locale-coding-system 'utf-8-unix | ||
159 | coding-system-for-read 'utf-8-unix | ||
160 | coding-system-for-write 'utf-8-unix | ||
161 | buffer-file-coding-system 'utf-8-unix | ||
162 | default-process-coding-system '(utf-8-unix . utf-8-unix) | ||
163 | x-select-request-type '(UTF8_STRING | ||
164 | COMPOUND_TEXT | ||
165 | TEXT | ||
166 | STRING)) | ||
167 | |||
168 | (set-charset-priority 'unicode) | ||
169 | (prefer-coding-system 'utf-8-unix) | ||
170 | (set-default-coding-systems 'utf-8-unix) | ||
171 | (set-terminal-coding-system 'utf-8-unix) | ||
172 | (set-keyboard-coding-system 'utf-8-unix) | ||
173 | |||
174 | (pcase system-type | ||
175 | ((or 'ms-dos 'windows-nt) | ||
176 | (set-clipboard-coding-system 'utf-16-le) | ||
177 | (set-selection-coding-system 'utf-16-le)) | ||
178 | (_ | ||
179 | (set-selection-coding-system 'utf-8) | ||
180 | (set-clipboard-coding-system 'utf-8))) | ||
181 | |||
182 | |||
183 | ;;; Modes | ||
184 | |||
185 | (dolist (enable-mode '(global-auto-revert-mode | ||
186 | blink-cursor-mode | ||
187 | electric-pair-mode | ||
188 | show-paren-mode | ||
189 | global-so-long-mode | ||
190 | minibuffer-depth-indicate-mode | ||
191 | file-name-shadow-mode | ||
192 | minibuffer-electric-default-mode | ||
193 | delete-selection-mode | ||
194 | auto-save-visited-mode | ||
195 | ;; column-number-mode | ||
196 | )) | ||
197 | (when (fboundp enable-mode) | ||
198 | (funcall enable-mode +1))) | ||
199 | |||
200 | (dolist (disable-mode '(tooltip-mode | ||
201 | tool-bar-mode | ||
202 | menu-bar-mode | ||
203 | scroll-bar-mode | ||
204 | horizontal-scroll-bar-mode)) | ||
205 | (when (fboundp disable-mode) | ||
206 | (funcall disable-mode -1))) | ||
207 | |||
208 | |||
209 | ;;; Hooks | ||
210 | |||
211 | (defun +auto-create-missing-dirs () | ||
212 | "Automatically create missing directories when finding a file." | ||
213 | ;; https://emacsredux.com/blog/2022/06/12/auto-create-missing-directories/ | ||
214 | (let ((target-dir (file-name-directory buffer-file-name))) | ||
215 | (unless (file-exists-p target-dir) | ||
216 | (make-directory target-dir t)))) | ||
217 | |||
218 | (defvar +save-some-buffers-debounce-time nil | ||
219 | "Last time `+save-some-buffers-debounce' was run.") | ||
220 | |||
221 | (defcustom +save-some-buffers-debounce-timeout 5 | ||
222 | "Number of seconds to wait before saving buffers again.") | ||
223 | |||
224 | (defun +save-some-buffers-debounce (&rest _) | ||
225 | "Run `save-some-buffers', but only if it's been a while." | ||
226 | (unless (and +save-some-buffers-debounce-time | ||
227 | (< (- (time-convert nil 'integer) +save-some-buffers-debounce-time) | ||
228 | +save-some-buffers-debounce-timeout)) | ||
229 | (save-some-buffers t) | ||
230 | (setf +save-some-buffers-debounce-time (time-convert nil 'integer)))) | ||
231 | |||
232 | |||
233 | ;;; Better-default functions ... | ||
234 | |||
235 | (defun +cycle-spacing (&optional n preserve-nl-back mode) | ||
236 | "Negate N argument on `cycle-spacing'. | ||
237 | That is, with a positive N, deletes newlines as well, leaving -N | ||
238 | spaces. If N is negative, it will not delete newlines and leave | ||
239 | N spaces. See docstring of `cycle-spacing' for the meaning of | ||
240 | PRESERVE-NL-BACK and MODE." | ||
241 | (interactive "*p") | ||
242 | (cycle-spacing (- n))) | ||
243 | |||
244 | (defun +save-buffers-quit (&optional arg) | ||
245 | "Silently save each buffer, then kill the current connection. | ||
246 | If the current frame has no client, kill Emacs itself using | ||
247 | `save-buffers-kill-emacs' after confirming with the user. | ||
248 | |||
249 | With prefix ARG, silently save all file-visiting buffers, then | ||
250 | kill without asking." | ||
251 | (interactive "P") | ||
252 | (save-some-buffers t) | ||
253 | (if (and (not (frame-parameter nil 'client)) | ||
254 | (and (not arg))) | ||
255 | (when (yes-or-no-p "Sure you want to quit? ") | ||
256 | (save-buffers-kill-emacs)) | ||
257 | (delete-frame nil :force))) | ||
258 | |||
259 | (defun +kill-word-backward-or-region (&optional arg backward-kill-word-fn) | ||
260 | "Kill active region or ARG words backward. | ||
261 | BACKWARD-KILL-WORD-FN is the function to call to kill a word | ||
262 | backward. It defaults to `backward-kill-word'." | ||
263 | (interactive "P") | ||
264 | (call-interactively (if (region-active-p) | ||
265 | #'kill-region | ||
266 | (or backward-kill-word-fn #'backward-kill-word)))) | ||
267 | |||
268 | (defun +backward-kill-word-wrapper (fn &optional arg) | ||
269 | "Kill backward using FN until the beginning of a word, smartly. | ||
270 | If point is on at the beginning of a line, kill the previous new | ||
271 | line. If the only thing before point on the current line is | ||
272 | whitespace, kill that whitespace. | ||
273 | |||
274 | With argument ARG: if ARG is a number, just call FN | ||
275 | ARG times. Otherwise, just call FN." | ||
276 | ;; I want this to be a wrapper so that I can call other word-killing functions | ||
277 | ;; with it. It's *NOT* advice because those functions probably use | ||
278 | ;; `backward-kill-word' under the hood (looking at you, paredit), so advice | ||
279 | ;; will make things weird. | ||
280 | (if (null arg) | ||
281 | (cond | ||
282 | ((looking-back "^" 1) | ||
283 | (let ((delete-active-region nil)) | ||
284 | (delete-backward-char 1))) | ||
285 | ((looking-back "^[ ]*") | ||
286 | (delete-horizontal-space :backward-only)) | ||
287 | (t (call-interactively fn))) | ||
288 | (funcall fn (if (listp arg) 1 arg)))) | ||
289 | |||
290 | (defun +backward-kill-word (&optional arg) | ||
291 | "Kill word backward using `backward-kill-word'. | ||
292 | ARG is passed to `backward-kill-word'." | ||
293 | (interactive "P") | ||
294 | (+backward-kill-word-wrapper #'backward-kill-word arg)) | ||
295 | |||
296 | ;;; ... and advice | ||
297 | |||
298 | ;; Indent the region after a yank. | ||
299 | (defun +yank@indent (&rest _) | ||
300 | "Indent the current region." | ||
301 | (indent-region (min (point) (mark)) (max (point) (mark)))) | ||
302 | ;; (advice-add #'yank :after #'+yank@indent) | ||
303 | ;; (advice-add #'yank-pop :after #'+yank@indent) | ||
304 | |||
305 | ;; https://old.reddit.com/r/emacs/comments/y92y4b/tramp_users_slowness_got_you_down_check/it3a35r/ | ||
306 | (defun +vc-off-when-remote () | ||
307 | (when (file-remote-p (buffer-file-name)) | ||
308 | (setq-local vc-handled-backends nil))) | ||
309 | |||
310 | |||
311 | ;;; Extra functions | ||
312 | |||
313 | (defun +save-some-buffers-p () | ||
314 | "Predicate for `save-some-buffers-default-predicate'. | ||
315 | It returns nil with remote files and those without attached files." | ||
316 | (and (buffer-file-name) | ||
317 | (not (file-remote-p (buffer-file-name))))) | ||
318 | |||
319 | ;; https://www.wwwtech.de/articles/2013/may/emacs:-jump-to-matching-paren-beginning-of-block | ||
320 | (defun +goto-matching-paren (&optional arg) | ||
321 | "Go to the matching paren, similar to vi's %." | ||
322 | (interactive "p") | ||
323 | (or arg (setf arg 1)) | ||
324 | (cond | ||
325 | ;; Check for "outside of bracket" positions | ||
326 | ((looking-at "[\[\(\{]") (forward-sexp arg)) | ||
327 | ((looking-back "[\]\)\}]" 1) (backward-sexp arg)) | ||
328 | ;; Otherwise, move from inside the bracket | ||
329 | ((looking-at "[\]\)\}]") (forward-char) (backward-sexp arg)) | ||
330 | ((looking-back "[\[\(\{]" 1) (backward-char) (forward-sexp arg)) | ||
331 | (t (up-list arg t t)))) | ||
332 | |||
333 | (defun +delete-window-or-bury-buffer () | ||
334 | "Delete the current window, or bury the current buffer. | ||
335 | If the current window is the only window, bury the buffer." | ||
336 | (interactive) | ||
337 | (condition-case e | ||
338 | (delete-window) | ||
339 | (t (bury-buffer)))) | ||
340 | |||
341 | |||
342 | ;;; Required libraries | ||
343 | |||
344 | (when (require 'abbrev nil :noerror) | ||
345 | (setq-default abbrev-file-name (sync/ "abbrev.el") | ||
346 | save-abbrevs 'silent)) | ||
347 | |||
348 | (when (require 'autorevert nil :noerror) | ||
349 | (setq-default global-auto-revert-non-file-buffers t | ||
350 | auto-revert-verbose nil) | ||
351 | (global-auto-revert-mode +1)) | ||
352 | |||
353 | (when (require 'uniquify nil :noerror) | ||
354 | (setq-default uniquify-buffer-name-style 'forward | ||
355 | uniquify-separator path-separator | ||
356 | uniquify-after-kill-buffer-p t | ||
357 | uniquify-ignore-buffers-re "^\\*")) | ||
358 | |||
359 | (when (require 'goto-addr) | ||
360 | (if (fboundp 'global-goto-address-mode) | ||
361 | (global-goto-address-mode +1) | ||
362 | (add-hook 'after-change-major-mode-hook 'goto-address-mode))) | ||
363 | |||
364 | (when (require 'recentf nil :noerror) | ||
365 | (setq-default recentf-save-file (.etc "recentf.el") | ||
366 | recentf-max-menu-items 100 | ||
367 | recentf-max-saved-items nil | ||
368 | recentf-auto-cleanup 'mode) | ||
369 | (add-to-list 'recentf-exclude .etc) | ||
370 | (recentf-mode +1)) | ||
371 | |||
372 | (when (require 'savehist nil :noerror) | ||
373 | (setq-default history-length t | ||
374 | history-delete-duplicates t | ||
375 | history-autosave-interval 60 | ||
376 | savehist-file (.etc "savehist.el") | ||
377 | ;; Other variables --- don't truncate any of these. | ||
378 | ;; `add-to-history' uses the values of these variables unless | ||
379 | ;; they're nil, in which case it falls back to `history-length'. | ||
380 | kill-ring-max 100 | ||
381 | mark-ring-max 100 | ||
382 | global-mark-ring-max 100 | ||
383 | regexp-search-ring-max 100 | ||
384 | search-ring-max 100 | ||
385 | kmacro-ring-max 100 | ||
386 | eww-history-limit 100) | ||
387 | (dolist (var '(extended-command-history | ||
388 | global-mark-ring | ||
389 | mark-ring | ||
390 | kill-ring | ||
391 | kmacro-ring | ||
392 | regexp-search-ring | ||
393 | search-ring)) | ||
394 | (add-to-list 'savehist-additional-variables var)) | ||
395 | (savehist-mode +1)) | ||
396 | |||
397 | (when (require 'saveplace nil :noerror) | ||
398 | (setq-default save-place-file (.etc "places.el") | ||
399 | save-place-forget-unreadable-files (eq system-type 'gnu/linux)) | ||
400 | (save-place-mode +1)) | ||
401 | |||
402 | ;; (when (require 'tramp) | ||
403 | ;; ;; thanks Irreal! https://irreal.org/blog/?p=895 | ||
404 | ;; (add-to-list 'tramp-default-proxies-alist | ||
405 | ;; '(nil "\\`root\\'" "/ssh:%h:")) | ||
406 | ;; (add-to-list 'tramp-default-proxies-alist | ||
407 | ;; '((regexp-quote (system-name)) nil nil))) | ||
408 | |||
409 | |||
410 | ;;; Newer features | ||
411 | ;; These aren't in older version of Emacs, but they're so nice. | ||
412 | |||
413 | (when (fboundp 'repeat-mode) | ||
414 | (setq-default repeat-exit-key "g" | ||
415 | repeat-exit-timeout 5) | ||
416 | (repeat-mode +1)) | ||
417 | |||
418 | (when (fboundp 'pixel-scroll-precision-mode) | ||
419 | (pixel-scroll-precision-mode +1)) | ||
420 | |||
421 | (provide '+emacs) | ||
422 | ;;; +emacs.el ends here | ||
diff --git a/lisp/+emms.el b/lisp/+emms.el new file mode 100644 index 0000000..a43daea --- /dev/null +++ b/lisp/+emms.el | |||
@@ -0,0 +1,38 @@ | |||
1 | ;;; +emms.el -*- lexical-binding: t; -*- | ||
2 | |||
3 | (defun +emms-streams (&optional file) | ||
4 | "Better interface for `emms-streams'. | ||
5 | If FILE is non-nil, use it. Otherwise use `emms-streams-file'. | ||
6 | If `emms-streams-file' is nil or this function is called with | ||
7 | \\[universal-argument], prompt the user." | ||
8 | (interactive | ||
9 | (list (cond | ||
10 | ((or emms-streams-file | ||
11 | (not current-prefix-arg)) | ||
12 | emms-streams-file) | ||
13 | (:else (read-file-name "Stream file: " | ||
14 | emms-source-file-default-directory))))) | ||
15 | (when (and (not (file-exists-p emms-streams-file)) | ||
16 | (y-or-n-p "Emms' bulit-in streams file hasn't been installed yet. Install it now?")) | ||
17 | (emms-streams-install)) | ||
18 | (let ((buf (get-buffer emms-streams-buffer-name))) | ||
19 | (when (not buf) | ||
20 | (with-current-buffer (get-buffer-create emms-streams-buffer-name) | ||
21 | (setq buf (current-buffer)) | ||
22 | (emms-playlist-mode) | ||
23 | (setq emms-playlist-buffer-p t) | ||
24 | (emms-playlist-set-playlist-buffer (current-buffer)) | ||
25 | (with-current-buffer (find-file-noselect emms-streams-file) | ||
26 | (cond | ||
27 | ((emms-source-playlist-native-p) | ||
28 | (emms-add-native-playlist emms-streams-file)) | ||
29 | ((emms-source-playlist-m3u-p) | ||
30 | (emms-add-m3u-playlist emms-streams-file)) | ||
31 | ((emms-source-playlist-pls-p) | ||
32 | (emms-add-pls-playlist emms-streams-file)) | ||
33 | (:else (error "Streams file `%s' isn't in a known format." | ||
34 | emms-streams-file)))))) | ||
35 | (switch-to-buffer buf))) | ||
36 | |||
37 | (provide '+emms) | ||
38 | ;;; +emms.el ends here | ||
diff --git a/lisp/+hungry-delete.el b/lisp/+hungry-delete.el new file mode 100644 index 0000000..601aecf --- /dev/null +++ b/lisp/+hungry-delete.el | |||
@@ -0,0 +1,53 @@ | |||
1 | ;;; +hungry-delete.el -*- lexical-binding: t; -*- | ||
2 | |||
3 | ;; Copyright (C) 2022 Case Duckworth | ||
4 | |||
5 | ;;; Code: | ||
6 | |||
7 | (require 'hungry-delete) | ||
8 | |||
9 | (defmacro +hungry-delete-define-alternative (func hd-func &optional direction) | ||
10 | "Define a `hungry-delete' alternative for FUNC. | ||
11 | If the adjacent characters in DIRECTION are one of | ||
12 | `hungry-delete-chars-to-skip', call HD-FUNC. Otherwise, call | ||
13 | FUNC. | ||
14 | |||
15 | If DIRECTION is a positive integer or `forward', look forward. | ||
16 | If it's negative or `backward', look backward. If it's absent, | ||
17 | this macro will try to guess based on the names of FUNC and | ||
18 | HD-FUNC. | ||
19 | |||
20 | This macro creates a function taking a prefix argument that's | ||
21 | passed to both of FUNC and HD-FUNC." | ||
22 | (let ((name (intern (format "%s|%s" func hd-func))) | ||
23 | (lookfn (cond | ||
24 | ((or (and (string-match-p "forward" (symbol-name func)) | ||
25 | (string-match-p "forward" (symbol-name hd-func)) | ||
26 | (not direction)) | ||
27 | (and (integerp direction) | ||
28 | (< 0 direction)) | ||
29 | (eq direction 'forward)) | ||
30 | 'looking-at) | ||
31 | ((or (and (string-match-p "backward" (symbol-name func)) | ||
32 | (string-match-p "backward" (symbol-name hd-func)) | ||
33 | (not direction)) | ||
34 | (and (integerp direction) | ||
35 | (> 0 direction)) | ||
36 | (eq direction 'backward)) | ||
37 | 'looking-back) | ||
38 | (:else (error "Bad direction: %S" direction)))) | ||
39 | (arg (gensym))) | ||
40 | `(defun ,name (,arg) | ||
41 | ,(concat (format "Do `%s' or `%s', depending on whitespace.\n" | ||
42 | func hd-func) | ||
43 | (format "Pass prefix argument %s to the underlying functions.\n" | ||
44 | (upcase (symbol-name arg))) | ||
45 | "This function was defined by `define-hungry-delete-alternative'.") | ||
46 | (interactive "*p") ; This is brittle | ||
47 | (if (,lookfn (format "[%s]" hungry-delete-chars-to-skip)) | ||
48 | (,hd-func (or ,arg 1)) | ||
49 | (,func ,arg))))) | ||
50 | |||
51 | (provide '+hungry-delete) | ||
52 | ;;; +hungry-delete.el ends here | ||
53 | |||
diff --git a/lisp/+isearch.el b/lisp/+isearch.el new file mode 100644 index 0000000..3516ec4 --- /dev/null +++ b/lisp/+isearch.el | |||
@@ -0,0 +1,24 @@ | |||
1 | ;;; +isearch.el --- iseach (and query-replace) extensions -*- lexical-binding: t; -*- | ||
2 | |||
3 | ;;; From https://github.com/astoff/isearch-mb/wiki | ||
4 | |||
5 | (defun +isearch-cancel@add-search-to-history () | ||
6 | "Add search string to history also when canceling. | ||
7 | This should be used as `:before' advice on `isearch-cancel'." | ||
8 | (unless (string-equal "" isearch-string) | ||
9 | (isearch-update-ring isearch-string isearch-regexp))) | ||
10 | |||
11 | (defun +perform-replace-dont-exit-on-anykey (orig &rest args) | ||
12 | "Don't exit replace for anykey that's not in `query-replace-map'. | ||
13 | This should be used as `:around' advice for `perform-replace'." | ||
14 | (save-window-excursion | ||
15 | (cl-letf* ((lookup-key-orig | ||
16 | (symbol-function 'lookup-key)) | ||
17 | ((symbol-function 'lookup-key) | ||
18 | (lambda (map key &optional accept-default) | ||
19 | (or (apply lookup-key-orig map key accept-default) | ||
20 | (when (eq map query-replace-map) 'help))))) | ||
21 | (apply orig args)))) | ||
22 | |||
23 | (provide '+isearch) | ||
24 | ;;; +isearch.el ends here | ||
diff --git a/lisp/+notmuch.el b/lisp/+notmuch.el index 74b9b77..5df6e5b 100644 --- a/lisp/+notmuch.el +++ b/lisp/+notmuch.el | |||
@@ -60,11 +60,11 @@ for search." | |||
60 | 'notmuch-address-history))) | 60 | 'notmuch-address-history))) |
61 | (:else | 61 | (:else |
62 | (defun notmuch-address-selection-function (prompt collection initial-input) | 62 | (defun notmuch-address-selection-function (prompt collection initial-input) |
63 | "Call (`completing-read' | 63 | "Call (`completing-read' |
64 | PROMPT COLLECTION nil nil INITIAL-INPUT 'notmuch-address-history)" | 64 | PROMPT COLLECTION nil nil INITIAL-INPUT 'notmuch-address-history)" |
65 | (completing-read | 65 | (completing-read |
66 | prompt collection nil nil nil | 66 | prompt collection nil nil nil |
67 | 'notmuch-address-history))))) | 67 | 'notmuch-address-history))))) |
68 | 68 | ||
69 | (defcustom +notmuch-spam-tags '("+spam" "+Spam") | 69 | (defcustom +notmuch-spam-tags '("+spam" "+Spam") |
70 | "A list of tag changes to apply when marking a thread as spam." | 70 | "A list of tag changes to apply when marking a thread as spam." |
@@ -101,5 +101,49 @@ This function advances the next thread when finished." | |||
101 | (when (eq beg end) | 101 | (when (eq beg end) |
102 | (notmuch-search-next-thread))) | 102 | (notmuch-search-next-thread))) |
103 | 103 | ||
104 | (defun +notmuch-tree-beginning (&optional arg) | ||
105 | "Move point to beginning of message or tree, depending on ARG." | ||
106 | (interactive "P") | ||
107 | (cond | ||
108 | ((and (window-live-p notmuch-tree-message-window) | ||
109 | (not arg)) | ||
110 | (with-selected-window notmuch-tree-message-window | ||
111 | (beginning-of-buffer))) | ||
112 | (:else (beginning-of-buffer)))) | ||
113 | |||
114 | (defun +notmuch-tree-end (&optional arg) | ||
115 | "Move point to end of message or tree, depending on ARG." | ||
116 | (interactive "P") | ||
117 | (cond | ||
118 | ((and (window-live-p notmuch-tree-message-window) | ||
119 | (not arg)) | ||
120 | (with-selected-window notmuch-tree-message-window | ||
121 | (end-of-buffer))) | ||
122 | (:else (end-of-buffer)))) | ||
123 | |||
124 | (defun +notmuch-make-saved-search (name key search-type &rest queries) | ||
125 | "Wrapper to ease `notmuch-saved-searches' defining. | ||
126 | NAME, KEY, and SEARCH-TYPE are paired with the corresponding keywords in | ||
127 | `notmuch-saved-searches', which see. QUERIES are all concatenated together with | ||
128 | AND. If QUERIES is prepended with more keyword arguments, those are added to | ||
129 | the saved search as well." | ||
130 | (declare (indent 3)) | ||
131 | (let (extra-keywords) | ||
132 | (while (keywordp (car queries)) | ||
133 | (push (cadr queries) extra-keywords) | ||
134 | (push (car queries) extra-keywords) | ||
135 | (setf queries (cddr queries))) | ||
136 | (add-to-list 'notmuch-saved-searches | ||
137 | (append | ||
138 | (list :name name | ||
139 | :key key | ||
140 | :search-type search-type | ||
141 | :query (apply #'+notmuch-query-concat queries)) | ||
142 | (reverse extra-keywords)) | ||
143 | :append | ||
144 | (lambda (a b) | ||
145 | (equal (plist-get a :name) | ||
146 | (plist-get b :name)))))) | ||
147 | |||
104 | (provide '+notmuch) | 148 | (provide '+notmuch) |
105 | ;;; +notmuch.el ends here | 149 | ;;; +notmuch.el ends here |
diff --git a/lisp/+org-capture.el b/lisp/+org-capture.el index 06dfcfd..2f7bf6a 100644 --- a/lisp/+org-capture.el +++ b/lisp/+org-capture.el | |||
@@ -1,164 +1,49 @@ | |||
1 | ;;; +org-capture.el -*- lexical-binding: t; -*- | 1 | ;;; +org-capture.el -*- lexical-binding: t; -*- |
2 | 2 | ||
3 | ;;; Code: | 3 | ;;; Code: |
4 | 4 | ||
5 | (require 'cl-lib) | 5 | (require 'cl-lib) |
6 | (require 'acdw) | 6 | ;; Don't /require/ `org-capture', since that'll pull in all of `org' and that'll |
7 | ;; We don't require `org-capture' here because I'll have to require this library | 7 | ;; take a minute. Just let the compiler know that this variable exists. |
8 | ;; to init.el /before/ org-capture is fully needed. But I do need to declare | ||
9 | ;; `org-capture-templates'. | ||
10 | (defvar org-capture-templates nil) | 8 | (defvar org-capture-templates nil) |
11 | 9 | ||
12 | (defun +org-capture--get (key &optional list) | 10 | ;; https://github.com/cadadr/configuration/blob/39813a771286e542af3aa333172858532c3bb257/emacs.d/gk/gk-org.el#L1573 |
13 | "Find KEY in LIST, or return nil. | 11 | (defun +org-capture-template-define (description &rest args) |
14 | LIST defaults to `org-capture-templates'." | 12 | "Define a capture template. |
15 | (alist-get key (or list org-capture-templates) nil nil #'equal)) | 13 | Creates a list and adds it to `org-capture-templates', if it's |
16 | 14 | not already there. ARGS is a plist, which in addition to the | |
17 | ;; Set it up as a generic value. Based on the one for `alist-get'. | 15 | additional options `org-capture-templates' accepts (which see), |
18 | (gv-define-expander +org-capture--get | 16 | takes the following and puts them in the right spot: `:keys', |
19 | (lambda (do key &optional alist) | 17 | `:description', `:type', `:target', and `:template'." |
20 | (setf alist (or alist org-capture-templates)) | 18 | (declare (indent 1)) |
21 | (macroexp-let2 macroexp-copyable-p k key | 19 | (let* ((keys (plist-get args :keys)) |
22 | (gv-letplace (getter setter) alist | 20 | (type (plist-get args :type)) |
23 | (macroexp-let2 nil p `(assoc ,k ,getter 'equal) | 21 | (target (plist-get args :target)) |
24 | (funcall do `(cdr ,p) | 22 | (template (plist-get args :template)) |
25 | (lambda (v) | 23 | (template-value (append |
26 | (macroexp-let2 nil v v | 24 | (list description) |
27 | (let ((set-exp | 25 | (when (or type target template) |
28 | `(if ,p (setcdr ,p ,v) | 26 | (list (or type 'entry) target template)) |
29 | ,(funcall setter | 27 | (cl-loop for i from 0 below (length args) by 2 |
30 | `(cons (setf ,p (cons ,k ,v)) | 28 | unless (member (nth i args) |
31 | ,getter))))) | 29 | '(:keys :description :type |
32 | `(progn | 30 | :target :template)) |
33 | ,set-exp | 31 | append (list (nth i args) |
34 | ,v)))))))))) | 32 | (plist-get args (nth i |
35 | 33 | args))))))) | |
36 | (defun +org-capture-sort (&optional list) | 34 | ;; The only way I know how to do this properly (add a value to the end of |
37 | "Sort LIST by string keys. | 35 | ;; the list, if it exists; otherwise update it) is to do this weird if-setf |
38 | LIST is a symbol and defaults to `org-capture-templates'." | 36 | ;; dance. |
39 | (setf list (or list 'org-capture-templates)) | 37 | (if (seq-find (lambda (el) (equal (car el) keys)) |
40 | (set list (sort (symbol-value list) (lambda (a b) | 38 | org-capture-templates) |
41 | (string< (car a) (car b)))))) | 39 | (setf (alist-get keys org-capture-templates nil nil #'equal) |
42 | 40 | template-value) | |
43 | (defun +org-capture-sort-after-init (&optional list) | 41 | (setf org-capture-templates |
44 | "Sort LIST with `+org-capture-sort' after Emacs init." | 42 | (append org-capture-templates |
45 | (+ensure-after-init #'+org-capture-sort)) | 43 | (list (cons keys template-value))))) |
46 | 44 | ;; Regardless of what we do, return the new value of | |
47 | ;;;###autoload | 45 | ;; `org-capture-templates'. |
48 | (defun +org-capture-templates-setf (key value &optional list sort-after) | 46 | org-capture-templates)) |
49 | "Add KEY to LIST, using `setf'. | ||
50 | LIST is a symbol and defaults to `org-capture-templates' -- so | ||
51 | this function sets values on a list that's structured as such. | ||
52 | |||
53 | Thus, KEY is a string key. If it's longer than one character, | ||
54 | this function will search LIST for each successive run of | ||
55 | characters before the final, ensuring sub-lists exist of the | ||
56 | form (CHARS DESCRIPTION). | ||
57 | |||
58 | For example, if KEY is \"abc\", first a LIST item of the form (a | ||
59 | DESCRIPTION), if non-existant, will be added to the list (with a | ||
60 | default description), then an item of the | ||
61 | form (\"ab\" DESCRIPTION), before adding (KEY VALUE) to the LIST. | ||
62 | |||
63 | VALUE is the template or group header required for | ||
64 | `org-capture-templates', which see. | ||
65 | |||
66 | SORT-AFTER, when set to t, will call | ||
67 | `+org-capture-templates-sort' after setting, to ensure org can | ||
68 | properly process the variable." | ||
69 | ;; LIST defaults to `org-capture-templates' | ||
70 | (declare (indent 2)) | ||
71 | (unless list (setf list 'org-capture-templates)) | ||
72 | ;; Ensure VALUE is a list to cons properly | ||
73 | (unless (listp value) (setf value (list value))) | ||
74 | (when (> (length key) 1) | ||
75 | ;; Check for existence of groups. | ||
76 | (let ((expected (cl-loop for i from 1 to (1- (length key)) | ||
77 | collect (substring key 0 i) into keys | ||
78 | finally return keys))) | ||
79 | (cl-loop for ek in expected | ||
80 | if (not (+org-capture--get ek (symbol-value list))) do | ||
81 | (setf (+org-capture--get ek (symbol-value list)) | ||
82 | (list (format "(Group %s)" ek)))))) | ||
83 | (prog1 ;; Set KEY to VALUE | ||
84 | (setf (+org-capture--get key (symbol-value list)) value) | ||
85 | ;; Sort after, maybe | ||
86 | (when sort-after (+org-capture-sort list)))) | ||
87 | |||
88 | (defun +org-template--ensure-path (keys &optional list) | ||
89 | "Ensure path of keys exists in `org-capture-templates'." | ||
90 | (unless list (setf list 'org-capture-templates)) | ||
91 | (when (> (length key) 1) | ||
92 | ;; Check for existence of groups. | ||
93 | (let ((expected (cl-loop for i from 1 to (1- (length key)) | ||
94 | collect (substring key 0 i) into keys | ||
95 | finally return keys))) | ||
96 | (cl-loop for ek in expected | ||
97 | if (not (+org-capture--get ek (symbol-value list))) do | ||
98 | (setf (+org-capture--get ek (symbol-value list)) | ||
99 | (list (format "(Group %s)" ek))))))) | ||
100 | |||
101 | (defcustom +org-capture-default-type 'entry | ||
102 | "Default template for `org-capture-templates'." | ||
103 | :type '(choice (const :tag "Entry" entry) | ||
104 | (const :tag "Item" item) | ||
105 | (const :tag "Check Item" checkitem) | ||
106 | (const :tag "Table Line" table-line) | ||
107 | (const :tag "Plain Text" plain))) | ||
108 | |||
109 | (defcustom +org-capture-default-target "" | ||
110 | "Default target for `org-capture-templates'." | ||
111 | ;; TODO: type | ||
112 | ) | ||
113 | |||
114 | (defcustom +org-capture-default-template nil | ||
115 | "Default template for `org-capture-templates'." | ||
116 | ;; TODO: type | ||
117 | ) | ||
118 | |||
119 | (defun +org-define-capture-templates-group (keys description) | ||
120 | "Add a group title to `org-capture-templates'." | ||
121 | (setf (+org-capture--get keys org-capture-templates) | ||
122 | (list description))) | ||
123 | |||
124 | ;; [[https://github.com/cadadr/configuration/blob/39813a771286e542af3aa333172858532c3bb257/emacs.d/gk/gk-org.el#L1573][from cadadr]] | ||
125 | (defun +org-define-capture-template (keys description &rest args) | ||
126 | "Define a capture template and necessary antecedents. | ||
127 | ARGS is a plist, which in addition to the additional options | ||
128 | `org-capture-templates' accepts, takes the following and places | ||
129 | them accordingly: :type, :target, and :template. Each of these | ||
130 | corresponds to the same field in `org-capture-templates's | ||
131 | docstring, which see. Likewise with KEYS and DESCRIPTION, which | ||
132 | are passed separately to the function. | ||
133 | |||
134 | This function will also create all the necessary intermediate | ||
135 | capture keys needed for `org-capture'; that is, if KEYS is | ||
136 | \"wcp\", entries for \"w\" and \"wc\" will both be ensured in | ||
137 | `org-capture-templates'." | ||
138 | (declare (indent 2)) | ||
139 | ;; Check for existence of parent groups | ||
140 | (when (> (length keys) 1) | ||
141 | (let ((expected (cl-loop for i from 1 to (1- (length keys)) | ||
142 | collect (substring 0 i) into keys | ||
143 | finally return keys))) | ||
144 | (cl-loop | ||
145 | for ek in expected | ||
146 | if (not (+org-capture--get ek org-capture-templates)) | ||
147 | do (+org-define-capture-templates-group ek (format "(Group %s)" ek))))) | ||
148 | (if (null args) | ||
149 | ;; Add the title | ||
150 | (+org-define-capture-templates-group keys description) | ||
151 | ;; Add the capture template. | ||
152 | (setf (+org-capture--get keys org-capture-templates) | ||
153 | (append (list (or (plist-get args :type) | ||
154 | +org-capture-default-type) | ||
155 | (or ( plist-get args :target) | ||
156 | +org-capture-default-target) | ||
157 | (or (plist-get args :template) | ||
158 | +org-capture-default-template)) | ||
159 | (cl-loop for (key val) on args by #'cddr | ||
160 | unless (member key '(:type :target :template)) | ||
161 | append (list key val)))))) | ||
162 | 47 | ||
163 | (provide '+org-capture) | 48 | (provide '+org-capture) |
164 | ;;; +org-capture.el ends here | 49 | ;;; +org-capture.el |
diff --git a/lisp/+org.el b/lisp/+org.el index 7698ec9..a148bd8 100644 --- a/lisp/+org.el +++ b/lisp/+org.el | |||
@@ -1,7 +1,13 @@ | |||
1 | ;;; +org.el --- -*- lexical-binding: t -*- | 1 | ;;; +org.el -*- lexical-binding: t; -*- |
2 | 2 | ||
3 | ;;; Org Return DWIM | 3 | ;;; Code: |
4 | ;; [[https://github.com/alphapapa/unpackaged.el][unpackaged]] and [[http://kitchingroup.cheme.cmu.edu/blog/2017/04/09/A-better-return-in-org-mode/][kitchin]] | 4 | |
5 | (require 'cl-lib) | ||
6 | (require 'seq) | ||
7 | |||
8 | ;;; Org-return DWIM | ||
9 | ;; https://github.com/alphapapa/unpackaged.el, | ||
10 | ;; http://kitchingroup.cheme.cmu.edu/blog/2017/04/09/A-better-return-in-org-mode/ | ||
5 | 11 | ||
6 | (defun +org-element-descendant-of (type element) | 12 | (defun +org-element-descendant-of (type element) |
7 | "Return non-nil if ELEMENT is a descendant of TYPE. | 13 | "Return non-nil if ELEMENT is a descendant of TYPE. |
@@ -94,53 +100,13 @@ With PREFIX, call `org-return'." | |||
94 | (t ; Otherwise---just call `org-return'. | 100 | (t ; Otherwise---just call `org-return'. |
95 | (org-return)))) | 101 | (org-return)))) |
96 | 102 | ||
97 | (defun +org-table-copy-down|+org-return (&optional n) | 103 | (defun +org-table-copy-down|+org-return-dwim (&optional n) |
98 | "Call `org-table-copy-down' or `+org-return' depending on context." | 104 | "Call `org-table-copy-down' or `+org-return' depending on context." |
99 | (interactive "P") | 105 | (interactive "P") |
100 | (if (org-table-check-inside-data-field 'noerror) | 106 | (if (org-table-check-inside-data-field 'noerror) |
101 | (org-table-copy-down (or n 1)) | 107 | (org-table-copy-down (or n 1)) |
102 | (+org-return-dwim n))) | 108 | (+org-return-dwim n))) |
103 | 109 | ||
104 | ;;; Copy org trees as HTML | ||
105 | |||
106 | ;; Thanks to Oleh Krehel, via [[https://emacs.stackexchange.com/questions/54292/copy-results-of-org-export-directly-to-clipboard][this StackExchange question]]. | ||
107 | (defun +org-export-clip-to-html | ||
108 | (&optional async subtreep visible-only body-only ext-plist post-process) | ||
109 | "Export region to HTML, and copy it to the clipboard. | ||
110 | Arguments ASYNC, SUBTREEP, VISIBLE-ONLY, BODY-ONLY, EXT-PLIST, | ||
111 | and POST-PROCESS are passed to `org-export-to-file'." | ||
112 | (interactive) ; XXX: hould this be interactive? | ||
113 | (message "Exporting Org to HTML...") | ||
114 | (let ((org-tmp-file "/tmp/org.html")) | ||
115 | (org-export-to-file 'html org-tmp-file | ||
116 | async subtreep visible-only body-only ext-plist post-process) | ||
117 | (start-process "xclip" "*xclip*" | ||
118 | "xclip" "-verbose" | ||
119 | "-i" org-tmp-file | ||
120 | "-t" "text/html" | ||
121 | "-selection" "clipboard")) | ||
122 | (message "Exporting Org to HTML...done.")) | ||
123 | |||
124 | ;; Specialized functions | ||
125 | (defun +org-export-clip-subtree-to-html () | ||
126 | "Export current subtree to HTML." | ||
127 | (interactive) | ||
128 | (+org-export-clip-to-html nil :subtree)) | ||
129 | |||
130 | ;;; Unsmartify quotes and dashes and stuff. | ||
131 | |||
132 | (defun +org-unsmartify () | ||
133 | "Replace \"smart\" punctuation with their \"dumb\" counterparts." | ||
134 | (interactive) | ||
135 | (save-excursion | ||
136 | (goto-char (point-min)) | ||
137 | (while (re-search-forward "[“”‘’–—]" nil t) | ||
138 | (let ((replace (pcase (match-string 0) | ||
139 | ((or "“" "”") "\"") | ||
140 | ((or "‘" "’") "'") | ||
141 | ("–" "--") | ||
142 | ("—" "---")))) | ||
143 | (replace-match replace nil nil))))) | ||
144 | 110 | ||
145 | ;;; A ... different ... `org-open-at-point-dwim' | 111 | ;;; A ... different ... `org-open-at-point-dwim' |
146 | ;; I honestly don't remember what the difference is between this and the | 112 | ;; I honestly don't remember what the difference is between this and the |
@@ -177,20 +143,7 @@ and POST-PROCESS are passed to `org-export-to-file'." | |||
177 | (org-up-heading-all 1)) | 143 | (org-up-heading-all 1)) |
178 | (org-open-at-point arg))))) | 144 | (org-open-at-point arg))))) |
179 | 145 | ||
180 | ;;; Skip invisible shit when moving around | ||
181 | (defun +org-ignore-invisible (fn &rest r) | ||
182 | ":around ADVICE to ignore invisible text in `org-mode' buffers." | ||
183 | ;; TODO: generalize to all modes | ||
184 | (cond ((and (derived-mode-p #'org-mode) | ||
185 | (org-invisible-p)) | ||
186 | (while (org-invisible-p) | ||
187 | (forward-char)) | ||
188 | (apply fn r)) | ||
189 | (t (apply fn r)))) | ||
190 | |||
191 | ;;; Faces | 146 | ;;; Faces |
192 | |||
193 | ;;; Better org faces | ||
194 | ;; see `org-emphasis-alist' | 147 | ;; see `org-emphasis-alist' |
195 | 148 | ||
196 | (defface org-bold '((t (:weight bold))) | 149 | (defface org-bold '((t (:weight bold))) |
@@ -205,63 +158,152 @@ and POST-PROCESS are passed to `org-export-to-file'." | |||
205 | (defface org-strikethrough '((t (:strike-through t))) | 158 | (defface org-strikethrough '((t (:strike-through t))) |
206 | "Strike-through face for `org-mode' documents.") | 159 | "Strike-through face for `org-mode' documents.") |
207 | 160 | ||
208 | ;; `org-verbatim' and `org-code' are apparently already things, so we skip them | 161 | ;;; Unsmartify |
209 | ;; here. | 162 | |
210 | 163 | (defun +org-unsmartify () | |
211 | ;;; Inhibit hooks on `org-agenda' | 164 | "Replace \"smart\" punctuation with their \"dumb\" counterparts." |
212 | ;; It's really annoying when I call `org-agenda' and five hundred Ispell | 165 | (interactive) |
213 | ;; processes are created because I have `flyspell-mode' in the hook. This mode | 166 | (save-excursion |
214 | ;; inhibits those hooks when entering the agenda, but runs them when opening the | 167 | (goto-char (point-min)) |
215 | ;; actual buffer. | 168 | (while (re-search-forward "[“”‘’–—]" nil t) |
216 | 169 | (let ((replace (pcase (match-string 0) | |
217 | (defun +org-agenda-inhibit-hooks (fn &rest r) | 170 | ((or "“" "”") "\"") |
218 | "Advice to inhibit hooks when entering `org-agenda'." | 171 | ((or "‘" "’") "'") |
219 | (let ((org-mode-hook nil)) | 172 | ("–" "--") |
220 | (apply fn r))) | 173 | ("—" "---")))) |
221 | 174 | (replace-match replace nil nil))))) | |
222 | (defvar-local +org-hook-has-run-p nil | 175 | |
223 | "Whether `org-mode-hook' has run in the current buffer.") | 176 | ;;; Copy org trees as HTML |
224 | 177 | ;; Thanks to Oleh Krehel: | |
225 | (defun +org-agenda-switch-run-hooks (&rest _) | 178 | ;; https://emacs.stackexchange.com/questions/54292/copy-results-of-org-export-directly-to-clipboard |
226 | "Advice to run `org-mode-hook' when entering org-mode. | 179 | |
227 | This should only fire when switching to a buffer from `org-agenda'." | 180 | (defun +org-export-clip-to-html |
228 | (unless +org-hook-has-run-p | 181 | (&optional async subtreep visible-only body-only ext-plist post-process) |
229 | (run-hooks 'org-mode-hook) | 182 | "Export region to HTML, and copy it to the clipboard. |
230 | (setq +org-hook-has-run-p t))) | 183 | Arguments ASYNC, SUBTREEP, VISIBLE-ONLY, BODY-ONLY, EXT-PLIST, |
231 | 184 | and POST-PROCESS are passed to `org-export-to-file'." | |
232 | (define-minor-mode +org-agenda-inhibit-hooks-mode | 185 | (interactive) ; XXX: hould this be interactive? |
233 | "Inhibit `org-mode-hook' when opening `org-agenda'." | 186 | (message "Exporting Org to HTML...") |
234 | :lighter " A/h" | 187 | (let ((org-tmp-file "/tmp/org.html")) |
235 | :global t | 188 | (org-export-to-file 'html org-tmp-file |
236 | (cond (+org-agenda-inhibit-hooks-mode | 189 | async subtreep visible-only body-only ext-plist post-process) |
237 | (advice-add 'org-agenda :around #'+org-agenda-inhibit-hooks) | 190 | ;; XXX: figure out which clipboard to use, or use something in Emacs |
238 | (advice-add 'org-agenda-switch-to :after #'+org-agenda-switch-run-hooks)) | 191 | (start-process "xclip" "*xclip*" |
239 | (:else | 192 | "xclip" "-verbose" |
240 | (advice-remove 'org-agenda #'+org-agenda-inhibit-hooks) | 193 | "-i" org-tmp-file |
241 | (advice-remove 'org-agenda-switch-to #'+org-agenda-switch-run-hooks)))) | 194 | "-t" "text/html" |
242 | 195 | "-selection" "clipboard")) | |
243 | ;;; Drawers | 196 | (message "Exporting Org to HTML...done.")) |
197 | |||
198 | ;; Specialized functions | ||
199 | (defun +org-export-clip-subtree-to-html () | ||
200 | "Export current subtree to HTML." | ||
201 | (interactive) | ||
202 | (+org-export-clip-to-html nil :subtree)) | ||
203 | |||
204 | ;;; Hide drawers on save, except the currently-expanded one | ||
205 | |||
244 | (defun +org-hide-drawers-except-point () | 206 | (defun +org-hide-drawers-except-point () |
245 | "Hide all drawers except for the one point is in." | 207 | "Hide all drawers except for the one point is in." |
246 | ;; Most of this bit is taken from `org-fold--hide-drawers'. | 208 | ;; Most of this bit is taken from `org-fold--hide-drawers'. |
247 | (let ((pt (point)) | 209 | (let ((pt (point)) |
248 | (begin (point-min)) | 210 | (begin (point-min)) |
249 | (end (point-max))) | 211 | (end (point-max))) |
250 | (save-excursion | 212 | (save-excursion |
251 | (goto-char begin) | 213 | (goto-char begin) |
252 | (while (and (< (point) end) | 214 | (while (and (< (point) end) |
253 | (re-search-forward org-drawer-regexp end t)) | 215 | (re-search-forward org-drawer-regexp end t)) |
254 | (if (org-fold-folded-p nil 'drawer) | 216 | (if (org-fold-folded-p nil 'drawer) |
255 | (goto-char (org-fold-next-folding-state-change 'drawer nil end)) | 217 | (goto-char (org-fold-next-folding-state-change 'drawer nil end)) |
256 | (let* ((drawer (org-element-at-point)) | 218 | (let* ((drawer (org-element-at-point)) |
257 | (type (org-element-type drawer)) | 219 | (type (org-element-type drawer)) |
258 | (el-begin (org-element-property :begin drawer)) | 220 | (el-begin (org-element-property :begin drawer)) |
259 | (el-end (org-element-property :end drawer))) | 221 | (el-end (org-element-property :end drawer))) |
260 | (when (memq type '(drawer property-drawer)) | 222 | (when (memq type '(drawer property-drawer)) |
261 | (org-fold-hide-drawer-toggle | 223 | (org-fold-hide-drawer-toggle |
262 | (if (< el-begin pt el-end) 'off 'on) | 224 | (if (< el-begin pt el-end) 'off 'on) |
263 | nil drawer) | 225 | nil drawer) |
264 | (goto-char el-end)))))))) | 226 | (goto-char el-end)))))))) |
227 | |||
228 | ;;; Define `ol' link types | ||
229 | |||
230 | (defmacro +org-link-define-type (type args &rest body) | ||
231 | "Define an org link TYPE. | ||
232 | A function named `+org-link-TYPE-open' will be created, with ARGS | ||
233 | as its arguments and BODY as its body. BODY can be blank, in | ||
234 | which case the user will be messaged (This is a good do-nothing | ||
235 | effect for exporting link types)." | ||
236 | (declare (indent 2) | ||
237 | (doc-string 3) | ||
238 | (debug (sexp sexp def-body))) | ||
239 | (let ((fn (intern (format "+org-link-%s-open" type))) | ||
240 | (body (or body `((message ,(format "%S: %%S" type) | ||
241 | ,(car args))))) | ||
242 | (type-string (format "%S" type))) | ||
243 | `(prog1 | ||
244 | (defun ,fn ,args ,@body) | ||
245 | (org-link-set-parameters ,type-string :follow #',fn)))) | ||
246 | |||
247 | ;;; Skip some files in `org-agenda' | ||
248 | |||
249 | (defcustom org-agenda-file-skip-regexp nil | ||
250 | "Files matching this regexp are removed from `org-agenda-files'." | ||
251 | :group 'org-agenda) | ||
252 | |||
253 | (defun org-agenda-files@skip-regexp (files) | ||
254 | "`:filter-return' advice to filter files in `org-agenda-file-skip-regexp'." | ||
255 | (when org-agenda-file-skip-regexp | ||
256 | (setq files | ||
257 | (seq-remove (lambda (file) | ||
258 | (string-match-p | ||
259 | org-agenda-file-skip-regexp file)) | ||
260 | files))) | ||
261 | files) | ||
262 | |||
263 | ;;; Prompt for stuff | ||
264 | |||
265 | (defun +org-prompt-for-property (property &optional clipboardp insert list) | ||
266 | "Prompt for PROPERTY and return a properly-formatted string. | ||
267 | Pre-fill the input with clipboard contents if they match CLIPBOARDP. If | ||
268 | CLIPBOARDP is nil or missing, don't pre-fill. | ||
269 | |||
270 | If INSERT is non-nil, insert the property into the property | ||
271 | drawer of the current org tree. | ||
272 | |||
273 | If LIST is non-nil, return the result as a list instead of a string." | ||
274 | (let* ((kill (current-kill 0)) | ||
275 | (value (read-string (concat property ": ") | ||
276 | (when (and clipboardp | ||
277 | (or (eq clipboardp t) | ||
278 | (funcall clipboardp kill))) | ||
279 | kill)))) | ||
280 | (when insert | ||
281 | (org-set-property property value)) | ||
282 | (if list | ||
283 | (list property value) | ||
284 | (format ":%s: %s" property value)))) | ||
265 | 285 | ||
286 | (defun +org-prompt-tags (&optional prompt global) | ||
287 | (let* ((buffer (org-capture-get :buffer)) | ||
288 | (file (buffer-file-name (or (buffer-base-buffer buffer) buffer))) | ||
289 | (org-last-tags-completion-table | ||
290 | (org-global-tags-completion-table | ||
291 | (if global (org-agenda-files) (list file)))) | ||
292 | (org-add-colon-after-tag-completion t) | ||
293 | (ins (mapconcat | ||
294 | #'identity | ||
295 | (let ((crm-separator "[ \t]*:[ \t]*")) | ||
296 | (completing-read-multiple | ||
297 | (or prompt "Tags: ") | ||
298 | org-last-tags-completion-table nil nil nil | ||
299 | 'org-tags-history)) | ||
300 | ":"))) | ||
301 | (when (org-string-nw-p ins) | ||
302 | (prog1 (concat | ||
303 | (unless (eq (char-before) ?:) ":") | ||
304 | ins | ||
305 | (unless (eq (char-after) ?:) ":")) | ||
306 | (when (org-at-heading-p) (org-align-tags)))))) | ||
266 | 307 | ||
267 | (provide '+org) | 308 | (provide '+org) |
309 | ;;; +org.el ends here | ||
diff --git a/lisp/+ox.el b/lisp/+ox.el deleted file mode 100644 index 8748a55..0000000 --- a/lisp/+ox.el +++ /dev/null | |||
@@ -1,29 +0,0 @@ | |||
1 | ;;; +ox.el --- org-export helpers -*- lexical-binding: t; -*- | ||
2 | |||
3 | ;;; Commentary: | ||
4 | |||
5 | ;;; Code: | ||
6 | |||
7 | (require 'ox) | ||
8 | |||
9 | ;;; Run hooks before doing any exporting at all | ||
10 | |||
11 | (defcustom +org-export-pre-hook nil | ||
12 | "Functions to run /before/ `org-export-as' does anything. | ||
13 | These will run on the buffer about to be exported, NOT a copy." | ||
14 | :type 'hook) | ||
15 | |||
16 | (defun +org-export-pre-run-hooks (&rest _) | ||
17 | "Run hooks in `+org-export-pre-hook'." | ||
18 | (run-hooks '+org-export-pre-hook)) | ||
19 | |||
20 | (defun +org-export-pre-hooks-insinuate () | ||
21 | "Advise `org-export-as' to run `+org-export-pre-hook'." | ||
22 | (advice-add 'org-export-as :before #'+org-export-pre-run-hooks)) | ||
23 | |||
24 | (defun +org-export-pre-hooks-remove () | ||
25 | "Remove pre-hook advice on `org-export-as'." | ||
26 | (advice-remove 'org-export-as #'+org-export-pre-run-hooks)) | ||
27 | |||
28 | (provide '+ox) | ||
29 | ;;; +ox.el ends here | ||
diff --git a/lisp/+paredit.el b/lisp/+paredit.el new file mode 100644 index 0000000..ab176b8 --- /dev/null +++ b/lisp/+paredit.el | |||
@@ -0,0 +1,26 @@ | |||
1 | ;;; +paredit.el -*- lexical-binding: t -*- | ||
2 | |||
3 | ;;; Fixing unquote-splicing behaviour with Paredit | ||
4 | ;; https://www.n16f.net/blog/fixing-unquote-splicing-behaviour-with-paredit/ | ||
5 | |||
6 | (require 'paredit) | ||
7 | (require 'seq) | ||
8 | |||
9 | (defcustom +paredit-no-space-prefixes '(",@") | ||
10 | "Prefix strings to not insert a space after in `paredit'." | ||
11 | :group 'paredit | ||
12 | :type '(repeat string)) | ||
13 | |||
14 | (defun +paredit-space-for-delimiter (endp delimiter) | ||
15 | (let ((point (point))) | ||
16 | (or endp | ||
17 | (seq-every-p | ||
18 | (lambda (prefix) | ||
19 | (and (> point (length prefix)) | ||
20 | (let ((start (- point (length prefix))) | ||
21 | (end point)) | ||
22 | (not (string= (buffer-substring start end) prefix))))) | ||
23 | +paredit-no-space-prefixes)))) | ||
24 | |||
25 | (provide '+paredit) | ||
26 | ;;; +paredit.el ends here | ||
diff --git a/lisp/+tempo.el b/lisp/+tempo.el deleted file mode 100644 index 2c81e54..0000000 --- a/lisp/+tempo.el +++ /dev/null | |||
@@ -1,45 +0,0 @@ | |||
1 | ;;; +tempo.el --- easier tempo definition -*- lexical-binding: t -*- | ||
2 | |||
3 | (require 'tempo) | ||
4 | (declare-function derived-mode-abbrev-table-name "tempo") | ||
5 | |||
6 | ;; TODO: I need to figure out where this function goes. | ||
7 | (defun delete2 (list &rest elems) | ||
8 | "Delete each element of ELEMS, and the next item, from LIST." | ||
9 | (let ((r nil)) | ||
10 | (while (consp list) | ||
11 | (if (member (car list) elems) | ||
12 | (setf list (cdr list)) | ||
13 | (setf r (cons (car list) r))) | ||
14 | (setf list (cdr list))) | ||
15 | (reverse r))) | ||
16 | |||
17 | (defmacro define-tempo (tag doc &rest elements) | ||
18 | "Define a template and add its tag to MODE's abbrev-table. | ||
19 | TAG, DOC, and ELEMENTS are passed to `tempo-define-template', which see. | ||
20 | ABBREV, if given, is the abbrev string to use for template expansion | ||
21 | under MODE's abbrev-table. If ABBREV isn't given, TAG will be used." | ||
22 | (declare (indent 1)) | ||
23 | (let* ((template (gensym)) | ||
24 | (tag (cond ((stringp tag) tag) | ||
25 | ((symbolp tag) (symbol-name tag)) | ||
26 | (t (user-error "TAG must be a string or symbol: %S" tag)))) | ||
27 | (mode (or (plist-get elements :mode) nil)) | ||
28 | (abbrev (or (plist-get elements :abbrev) tag)) | ||
29 | (taglist (or (plist-get elements :taglist) nil)) | ||
30 | (table (let ((tname (and mode (derived-mode-abbrev-table-name mode)))) | ||
31 | (while (and tname (not (memq tname abbrev-table-name-list))) | ||
32 | (setq tname (and (get mode 'derived-mode-parent) | ||
33 | (derived-mode-abbrev-table-name | ||
34 | (get mode 'derived-mode-parent))))) | ||
35 | (or tname 'global-abbrev-table))) | ||
36 | (elements (delete2 elements :mode :abbrev :taglist))) | ||
37 | `(let ((,template (tempo-define-template ,tag | ||
38 | ',elements | ||
39 | ,(or abbrev tag) | ||
40 | ,doc | ||
41 | ,taglist))) | ||
42 | (define-abbrev ,table ,tag "" ,template :system t) | ||
43 | (put ,template 'no-self-insert t)))) | ||
44 | |||
45 | (provide '+tempo) | ||
diff --git a/lisp/+titlecase.el b/lisp/+titlecase.el index 9266807..6defda7 100644 --- a/lisp/+titlecase.el +++ b/lisp/+titlecase.el | |||
@@ -22,11 +22,13 @@ With prefix ARG, toggle the value of | |||
22 | ;; See also `org-map-tree'. I'm not using that function because I want to | 22 | ;; See also `org-map-tree'. I'm not using that function because I want to |
23 | ;; skip the first headline. A better solution would be to patch | 23 | ;; skip the first headline. A better solution would be to patch |
24 | ;; `titlecase-line' to ignore org-mode metadata (TODO cookies, tags, etc). | 24 | ;; `titlecase-line' to ignore org-mode metadata (TODO cookies, tags, etc). |
25 | (let ((level (funcall outline-level))) | 25 | (let ((level (funcall outline-level)) |
26 | (org-special-ctrl-a/e t)) | ||
26 | (while (and (progn (outline-next-heading) | 27 | (while (and (progn (outline-next-heading) |
27 | (> (funcall outline-level) level)) | 28 | (> (funcall outline-level) level)) |
28 | (not (eobp))) | 29 | (not (eobp))) |
29 | (titlecase-line))))) | 30 | (titlecase-region (org-beginning-of-line) |
31 | (org-end-of-line)))))) | ||
30 | 32 | ||
31 | (provide '+titlecase) | 33 | (provide '+titlecase) |
32 | ;;; +titlecase.el ends here | 34 | ;;; +titlecase.el ends here |
diff --git a/lisp/+window.el b/lisp/+window.el deleted file mode 100644 index 52b3712..0000000 --- a/lisp/+window.el +++ /dev/null | |||
@@ -1,130 +0,0 @@ | |||
1 | ;;; +window.el --- Fixes for Emacs's window.el -*- lexical-binding: t; -*- | ||
2 | |||
3 | ;;; Commentary: | ||
4 | |||
5 | ;; Do I want to propose this change in the Emacs ML? | ||
6 | |||
7 | ;;; Code: | ||
8 | |||
9 | (require 'window) | ||
10 | |||
11 | ;;; Split windows based on `window-total-width', not `window-width' | ||
12 | ;; I have to just redefine these functions because the check is really deep in | ||
13 | ;; there. | ||
14 | |||
15 | (defun window-splittable-p (window &optional horizontal) | ||
16 | "Return non-nil if `split-window-sensibly' may split WINDOW. | ||
17 | Optional argument HORIZONTAL nil or omitted means check whether | ||
18 | `split-window-sensibly' may split WINDOW vertically. HORIZONTAL | ||
19 | non-nil means check whether WINDOW may be split horizontally. | ||
20 | |||
21 | WINDOW may be split vertically when the following conditions | ||
22 | hold: | ||
23 | - `window-size-fixed' is either nil or equals `width' for the | ||
24 | buffer of WINDOW. | ||
25 | - `split-height-threshold' is an integer and WINDOW is at least as | ||
26 | high as `split-height-threshold'. | ||
27 | - When WINDOW is split evenly, the emanating windows are at least | ||
28 | `window-min-height' lines tall and can accommodate at least one | ||
29 | line plus - if WINDOW has one - a mode line. | ||
30 | |||
31 | WINDOW may be split horizontally when the following conditions | ||
32 | hold: | ||
33 | - `window-size-fixed' is either nil or equals `height' for the | ||
34 | buffer of WINDOW. | ||
35 | - `split-width-threshold' is an integer and WINDOW is at least as | ||
36 | wide as `split-width-threshold'. | ||
37 | - When WINDOW is split evenly, the emanating windows are at least | ||
38 | `window-min-width' or two (whichever is larger) columns wide." | ||
39 | (when (and (window-live-p window) | ||
40 | (not (window-parameter window 'window-side))) | ||
41 | (with-current-buffer (window-buffer window) | ||
42 | (if horizontal | ||
43 | ;; A window can be split horizontally when its width is not | ||
44 | ;; fixed, it is at least `split-width-threshold' columns wide | ||
45 | ;; and at least twice as wide as `window-min-width' and 2 (the | ||
46 | ;; latter value is hardcoded). | ||
47 | (and (memq window-size-fixed '(nil height)) | ||
48 | ;; Testing `window-full-width-p' here hardly makes any | ||
49 | ;; sense nowadays. This can be done more intuitively by | ||
50 | ;; setting up `split-width-threshold' appropriately. | ||
51 | (numberp split-width-threshold) | ||
52 | (>= (window-total-width window) | ||
53 | (max split-width-threshold | ||
54 | (* 2 (max window-min-width 2))))) | ||
55 | ;; A window can be split vertically when its height is not | ||
56 | ;; fixed, it is at least `split-height-threshold' lines high, | ||
57 | ;; and it is at least twice as high as `window-min-height' and 2 | ||
58 | ;; if it has a mode line or 1. | ||
59 | (and (memq window-size-fixed '(nil width)) | ||
60 | (numberp split-height-threshold) | ||
61 | (>= (window-height window) | ||
62 | (max split-height-threshold | ||
63 | (* 2 (max window-min-height | ||
64 | (if mode-line-format 2 1)))))))))) | ||
65 | |||
66 | (defun split-window-sensibly (&optional window) | ||
67 | "Split WINDOW in a way suitable for `display-buffer'. | ||
68 | WINDOW defaults to the currently selected window. | ||
69 | If `split-height-threshold' specifies an integer, WINDOW is at | ||
70 | least `split-height-threshold' lines tall and can be split | ||
71 | vertically, split WINDOW into two windows one above the other and | ||
72 | return the lower window. Otherwise, if `split-width-threshold' | ||
73 | specifies an integer, WINDOW is at least `split-width-threshold' | ||
74 | columns wide and can be split horizontally, split WINDOW into two | ||
75 | windows side by side and return the window on the right. If this | ||
76 | can't be done either and WINDOW is the only window on its frame, | ||
77 | try to split WINDOW vertically disregarding any value specified | ||
78 | by `split-height-threshold'. If that succeeds, return the lower | ||
79 | window. Return nil otherwise. | ||
80 | |||
81 | By default `display-buffer' routines call this function to split | ||
82 | the largest or least recently used window. To change the default | ||
83 | customize the option `split-window-preferred-function'. | ||
84 | |||
85 | You can enforce this function to not split WINDOW horizontally, | ||
86 | by setting (or binding) the variable `split-width-threshold' to | ||
87 | nil. If, in addition, you set `split-height-threshold' to zero, | ||
88 | chances increase that this function does split WINDOW vertically. | ||
89 | |||
90 | In order to not split WINDOW vertically, set (or bind) the | ||
91 | variable `split-height-threshold' to nil. Additionally, you can | ||
92 | set `split-width-threshold' to zero to make a horizontal split | ||
93 | more likely to occur. | ||
94 | |||
95 | Have a look at the function `window-splittable-p' if you want to | ||
96 | know how `split-window-sensibly' determines whether WINDOW can be | ||
97 | split." | ||
98 | (let ((window (or window (selected-window)))) | ||
99 | (or (and (window-splittable-p window) | ||
100 | ;; Split window vertically. | ||
101 | (with-selected-window window | ||
102 | (split-window-below))) | ||
103 | (and (window-splittable-p window t) | ||
104 | ;; Split window horizontally. | ||
105 | (with-selected-window window | ||
106 | (split-window-right))) | ||
107 | (and | ||
108 | ;; If WINDOW is the only usable window on its frame (it is | ||
109 | ;; the only one or, not being the only one, all the other | ||
110 | ;; ones are dedicated) and is not the minibuffer window, try | ||
111 | ;; to split it vertically disregarding the value of | ||
112 | ;; `split-height-threshold'. | ||
113 | (let ((frame (window-frame window))) | ||
114 | (or | ||
115 | (eq window (frame-root-window frame)) | ||
116 | (catch 'done | ||
117 | (walk-window-tree (lambda (w) | ||
118 | (unless (or (eq w window) | ||
119 | (window-dedicated-p w)) | ||
120 | (throw 'done nil))) | ||
121 | frame nil 'nomini) | ||
122 | t))) | ||
123 | (not (window-minibuffer-p window)) | ||
124 | (let ((split-height-threshold 0)) | ||
125 | (when (window-splittable-p window) | ||
126 | (with-selected-window window | ||
127 | (split-window-below)))))))) | ||
128 | |||
129 | (provide '+window) | ||
130 | ;;; +window.el ends here | ||
diff --git a/lisp/acdw-defaults.el b/lisp/acdw-defaults.el new file mode 100644 index 0000000..80b2bcc --- /dev/null +++ b/lisp/acdw-defaults.el | |||
@@ -0,0 +1,292 @@ | |||
1 | ;;; acdw-defaults.el --- measured defaults for Emacs -*- lexical-binding: t -*- | ||
2 | ;; by C. Duckworth <acdw@acdw.net> | ||
3 | |||
4 | ;;; Commentary: | ||
5 | |||
6 | ;; I find myself copy-pasting a lot of "boilerplate" type code when | ||
7 | ;; bankrupting my Emacs config and starting afresh. Instead of doing | ||
8 | ;; that, I'm putting it here, where it'll be easier to include in my | ||
9 | ;; config. | ||
10 | |||
11 | ;; Of course, some might say I could just ... stop bankrupting my | ||
12 | ;; Emacs. But like, why would I want to? | ||
13 | |||
14 | ;;; Code: | ||
15 | |||
16 | (require 'seq) | ||
17 | |||
18 | (defvar default-ring-max 256 | ||
19 | "Default maximum for ring variables.") | ||
20 | |||
21 | (unless (boundp 'use-short-answers) | ||
22 | (fset 'yes-or-no-p 'y-or-n-p)) | ||
23 | |||
24 | (setc async-shell-command-buffer 'new-buffer | ||
25 | async-shell-command-display-buffer nil | ||
26 | auto-hscroll-mode t | ||
27 | auto-window-vscroll nil | ||
28 | cursor-in-non-selected-windows 'hollow | ||
29 | cursor-type 'bar | ||
30 | echo-keystrokes 0.01 | ||
31 | fast-but-imprecise-scrolling t | ||
32 | fill-column 80 | ||
33 | global-mark-ring-max default-ring-max | ||
34 | hscroll-margin 1 | ||
35 | hscroll-step 1 | ||
36 | inhibit-startup-screen t | ||
37 | initial-buffer-choice t | ||
38 | kill-do-not-save-duplicates t | ||
39 | kill-read-only-ok t | ||
40 | kill-ring-max default-ring-max | ||
41 | kmacro-ring-max default-ring-max | ||
42 | mark-ring-max default-ring-max | ||
43 | read-answer-short t | ||
44 | read-process-output-max (* 10 1024 1024) | ||
45 | ring-bell-function #'ignore | ||
46 | save-interprogram-paste-before-kill t | ||
47 | scroll-conservatively 25 | ||
48 | scroll-margin 0 | ||
49 | scroll-preserve-screen-position 1 | ||
50 | scroll-step 1 | ||
51 | sentence-end-double-space t | ||
52 | set-mark-command-repeat-pop t | ||
53 | tab-width 8 | ||
54 | undo-limit (* 10 1024 1024) | ||
55 | use-dialog-box nil | ||
56 | use-file-dialog nil | ||
57 | use-short-answers t | ||
58 | window-resize-pixelwise t | ||
59 | yank-pop-change-selection t) | ||
60 | |||
61 | ;;; Encodings | ||
62 | |||
63 | ;; Allegedly, this is the only one you need... | ||
64 | (set-language-environment "UTF-8") | ||
65 | ;; But I still set all of these, for fun. | ||
66 | (setq-default buffer-file-coding-system 'utf-8-unix | ||
67 | coding-system-for-read 'utf-8-unix | ||
68 | coding-system-for-write 'utf-8-unix | ||
69 | default-process-coding-system '(utf-8-unix . utf-8-unix) | ||
70 | locale-coding-system 'utf-8-unix | ||
71 | x-select-request-type '(UTF8_STRING | ||
72 | COMPOUND_TEXT | ||
73 | TEXT | ||
74 | STRING)) | ||
75 | |||
76 | (set-charset-priority 'unicode) | ||
77 | (prefer-coding-system 'utf-8-unix) | ||
78 | (set-default-coding-systems 'utf-8-unix) | ||
79 | (set-terminal-coding-system 'utf-8-unix) | ||
80 | (set-keyboard-coding-system 'utf-8-unix) | ||
81 | |||
82 | (pcase system-type | ||
83 | ((or 'ms-dos 'windows-nt) | ||
84 | (set-clipboard-coding-system 'utf-16-le) | ||
85 | (set-selection-coding-system 'utf-16-le)) | ||
86 | (_ | ||
87 | (set-selection-coding-system 'utf-8) | ||
88 | (set-clipboard-coding-system 'utf-8))) | ||
89 | |||
90 | ;;; Modes | ||
91 | |||
92 | (dolist (enable-mode '(;; Enable these modes on startup | ||
93 | delete-selection-mode | ||
94 | global-so-long-mode | ||
95 | )) | ||
96 | (funcall enable-mode +1)) | ||
97 | |||
98 | (dolist (disable-mode '(;; Disable these modes on startup | ||
99 | horizontal-scroll-bar-mode | ||
100 | menu-bar-mode | ||
101 | scroll-bar-mode | ||
102 | tool-bar-mode | ||
103 | tooltip-mode | ||
104 | )) | ||
105 | (funcall disable-mode -1)) | ||
106 | |||
107 | ;;; Internal packages | ||
108 | |||
109 | (when (require 'abbrev nil t) | ||
110 | (custom-set-variables | ||
111 | '(abbrev-file-name (sync/ "abbrev.el")) | ||
112 | '(save-abbrevs 'silently))) | ||
113 | |||
114 | (when (require 'autorevert nil t) | ||
115 | (custom-set-variables | ||
116 | '(auto-revert-verbose nil) | ||
117 | '(global-auto-revert-non-file-buffers t)) | ||
118 | (global-auto-revert-mode +1)) | ||
119 | |||
120 | (when (require 'comp nil t) | ||
121 | (custom-set-variables | ||
122 | '(native-comp-async-report-warnings-errors 'silent) | ||
123 | '(native-comp-deferred-compilation t))) | ||
124 | |||
125 | (when (require 'custom nil t) | ||
126 | (custom-set-variables | ||
127 | '(custom-file (etc/ "custom.el")))) | ||
128 | |||
129 | (when (require 'ediff nil t) | ||
130 | (custom-set-variables | ||
131 | '(ediff-window-setup-function #'ediff-setup-windows-plain))) | ||
132 | |||
133 | (when (require 'eldoc nil t) | ||
134 | (custom-set-variables | ||
135 | '(eldoc-echo-area-use-multiline-p nil) | ||
136 | '(eldoc-idle-delay 0.1))) | ||
137 | |||
138 | (when (require 'executable nil t) | ||
139 | (custom-set-variables | ||
140 | '(executable-prefix-env t))) | ||
141 | |||
142 | (when (require 'files nil t) | ||
143 | (custom-set-variables | ||
144 | '(auto-save-default nil) | ||
145 | '(auto-save-interval 1) | ||
146 | '(auto-save-no-message t) | ||
147 | '(auto-save-timeout 1) | ||
148 | '(auto-save-visited-interval 1) | ||
149 | '(backup-by-copying t) | ||
150 | '(create-lockfiles nil) | ||
151 | '(delete-old-versions t) | ||
152 | '(find-file-visit-truename t) | ||
153 | '(kept-new-versions 8) | ||
154 | '(kept-old-versions 8) | ||
155 | '(mode-require-final-newline t) | ||
156 | '(version-control t) | ||
157 | '(view-read-only t)) | ||
158 | (dolist (h/f | ||
159 | '((after-save-hook . executable-make-buffer-file-executable-if-script-p) | ||
160 | (find-file-not-found-functions . create-missing-directories) | ||
161 | (find-file-hook . +vc-off@remote))) | ||
162 | (add-hook (car h/f) (cdr h/f))) | ||
163 | (auto-save-visited-mode)) | ||
164 | |||
165 | (when (require 'frame nil t) | ||
166 | (custom-set-variables | ||
167 | '(blink-cursor-blinks 1) | ||
168 | '(blink-cursor-interval 0.25) | ||
169 | '(blink-cursor-delay 0.25)) | ||
170 | (blink-cursor-mode)) | ||
171 | |||
172 | (when (require 'goto-addr nil t) | ||
173 | (if (fboundp 'global-goto-address-mode) | ||
174 | (global-goto-address-mode +1) | ||
175 | (add-hook 'after-change-major-mode-hook 'goto-address-mode))) | ||
176 | |||
177 | (when (require 'ibuffer nil t) | ||
178 | (global-set-key (kbd "C-x C-b") #'ibuffer) | ||
179 | (add-hook 'ibuffer-mode-hook #'hl-line-mode)) | ||
180 | |||
181 | (when (require 'image nil t) | ||
182 | (custom-set-variables | ||
183 | '(image-use-external-converter | ||
184 | (seq-some #'executable-find '("convert" "gm" "ffmpeg"))))) | ||
185 | |||
186 | (when (require 'imenu nil t) | ||
187 | (custom-set-variables | ||
188 | '(imenu-auto-rescan t))) | ||
189 | |||
190 | (when (require 'isearch nil t) | ||
191 | (custom-set-variables | ||
192 | '(regexp-search-ring-max default-ring-max) | ||
193 | '(search-ring-max default-ring-max))) | ||
194 | |||
195 | (when (require 'minibuffer nil t) | ||
196 | (custom-set-variables | ||
197 | '(completion-category-defaults nil) | ||
198 | '(completion-category-overrides '((file (styles partial-completion)))) | ||
199 | '(completion-ignore-case t) | ||
200 | '(completion-styles '(substring partial-completion)) | ||
201 | '(enable-recursive-minibuffers t) | ||
202 | '(file-name-shadow-properties '(invisible t intangible t)) | ||
203 | '(minibuffer-eldef-shorten-default t) | ||
204 | '(minibuffer-prompt-properties '( read-only t | ||
205 | cursor-intangible t | ||
206 | face minibuffer-prompt)) | ||
207 | '(read-buffer-completion-ignore-case t)) | ||
208 | (file-name-shadow-mode) | ||
209 | (minibuffer-electric-default-mode)) | ||
210 | |||
211 | (when (require 'mouse nil t) | ||
212 | (custom-set-variables | ||
213 | '(mouse-drag-copy-region t) | ||
214 | '(mouse-wheel-progressive-speed nil) | ||
215 | '(mouse-yank-at-point t))) | ||
216 | |||
217 | (when (require 'paren nil t) | ||
218 | (custom-set-variables | ||
219 | '(show-paren-delay 0.01) | ||
220 | '(show-paren-style 'parenthesis) | ||
221 | '(show-paren-when-point-in-periphery t) | ||
222 | '(show-paren-when-point-inside-paren t)) | ||
223 | (show-paren-mode) | ||
224 | (electric-pair-mode)) | ||
225 | |||
226 | (when (require 'recentf nil t) | ||
227 | (custom-set-variables | ||
228 | '(recentf-save-file (var/ "recentf.el")) | ||
229 | '(recentf-max-menu-items default-ring-max) | ||
230 | '(recentf-max-saved-items nil) | ||
231 | '(recentf-auto-cleanup 'mode)) | ||
232 | (add-to-list 'recentf-exclude etc/) | ||
233 | (add-to-list 'recentf-exclude var/) | ||
234 | (add-to-list 'recentf-exclude cache/) | ||
235 | (add-to-list 'recentf-exclude "-autoloads.el\\'") | ||
236 | (recentf-mode +1)) | ||
237 | |||
238 | (when (require 'savehist nil t) | ||
239 | (custom-set-variables | ||
240 | '(history-length 1024) | ||
241 | '(history-delete-duplicates t) | ||
242 | '(savehist-file (var/ "savehist.el")) | ||
243 | '(savehist-save-minibuffer-history t) | ||
244 | '(savehist-autosave-interval 30) | ||
245 | ;; Other variables --- don't truncate any of these. | ||
246 | ;; `add-to-history' uses the values of these variables unless | ||
247 | ;; they're nil, in which case it falls back to `history-length'. | ||
248 | '(kill-ring-max default-ring-max) | ||
249 | '(mark-ring-max default-ring-max) | ||
250 | '(global-mark-ring-max default-ring-max) | ||
251 | '(regexp-search-ring-max default-ring-max) | ||
252 | '(search-ring-max default-ring-max) | ||
253 | '(kmacro-ring-max default-ring-max) | ||
254 | '(eww-history-limit default-ring-max)) | ||
255 | (dolist (var '(global-mark-ring | ||
256 | mark-ring | ||
257 | kill-ring | ||
258 | kmacro-ring | ||
259 | regexp-search-ring | ||
260 | search-ring)) | ||
261 | (add-to-list 'savehist-additional-variables var)) | ||
262 | (savehist-mode +1)) | ||
263 | |||
264 | (when (require 'saveplace nil t) | ||
265 | (custom-set-variables | ||
266 | '(save-place-file (var/ "places.el")) | ||
267 | '(save-place-forget-unreadable-files (eq system-type 'gnu/linux))) | ||
268 | (save-place-mode 1)) | ||
269 | |||
270 | (when (require 'uniquify nil t) | ||
271 | (custom-set-variables | ||
272 | '(uniquify-after-kill-buffer-p t) | ||
273 | '(uniquify-buffer-name-style 'forward) | ||
274 | '(uniquify-ignore-buffers-re "^\\*") | ||
275 | '(uniquify-separator path-separator))) | ||
276 | |||
277 | (when (require 'vc nil t) | ||
278 | (custom-set-variables | ||
279 | '(vc-follow-symlinks t) | ||
280 | '(vc-make-backup-files t))) | ||
281 | |||
282 | (when (require 'window nil t) | ||
283 | (custom-set-variables | ||
284 | '(recenter-positions '(top 2 middle bottom)))) | ||
285 | |||
286 | ;;; New features | ||
287 | |||
288 | (when (fboundp 'pixel-scroll-precision-mode) | ||
289 | (pixel-scroll-precision-mode)) | ||
290 | |||
291 | (provide 'acdw-defaults) | ||
292 | ;;; acdw-defaults.el ends here | ||
diff --git a/lisp/acdw-funs.el b/lisp/acdw-funs.el new file mode 100644 index 0000000..ed41a61 --- /dev/null +++ b/lisp/acdw-funs.el | |||
@@ -0,0 +1,262 @@ | |||
1 | ;;; acdw-funs.el --- extra functions -*- lexical-binding: t -*- | ||
2 | |||
3 | |||
4 | ;;; Cribs from CRUX --- Advice | ||
5 | ;; https://github.com/bbatsov/crux | ||
6 | |||
7 | ;; All of these should go `:before' the function they're advising | ||
8 | (defun advise-region-or-buffer (&rest _) | ||
9 | "`:before' advice to work on the active region or whole buffer. | ||
10 | See also `with-region-or-buffer'." | ||
11 | (interactive (if mark-active | ||
12 | (list (region-beginning) (region-end)) | ||
13 | (list (point-min) (point-max))))) | ||
14 | |||
15 | (defun advise-region-or-line (&rest _) | ||
16 | "`:before' advice to work on the active region or whole line. | ||
17 | See also `with-region-or-line'." | ||
18 | (interactive (if mark-active | ||
19 | (list (region-beginning) (region-end)) | ||
20 | (list (line-beginning-position) (line-end-position))))) | ||
21 | |||
22 | (defun advise-region-or-to-eol (&rest _) | ||
23 | "`:before' advice to work on the active region or to end of line. | ||
24 | See also `with-region-or-to-eol'." | ||
25 | (INTERACTIVE (if mark-active | ||
26 | (list (region-beginning) (region-end)) | ||
27 | (list (point) (line-end-position))))) | ||
28 | |||
29 | |||
30 | ;;; Other functions and whatnot | ||
31 | |||
32 | (defun delete2 (list &rest elems) | ||
33 | "Delete each element of ELEMS, and the next item, from LIST." | ||
34 | (let ((r nil)) | ||
35 | (while (consp list) | ||
36 | (if (member (car list) elems) | ||
37 | (setf list (cdr list)) | ||
38 | (setf r (cons (car list) r))) | ||
39 | (setf list (cdr list))) | ||
40 | (reverse r))) | ||
41 | |||
42 | (unless (fboundp 'ensure-list) | ||
43 | (defun ensure-list (object) | ||
44 | "Return OBJECT as a list. | ||
45 | If OBJECT is already a list, return OBJECT itself. If it's | ||
46 | not a list, return a one-element list containing OBJECT." | ||
47 | (if (listp object) | ||
48 | object | ||
49 | (list object)))) | ||
50 | |||
51 | (defun +require (&rest features) | ||
52 | "Require FEATURES, plus my extras. | ||
53 | Each feature can be an atom (the feature name) or a list of the form | ||
54 | (FEATURE &optional FILENAME NOERROR), which is passed directly to | ||
55 | `require'. My extras are in lisp/ and named +FEATURE, so this | ||
56 | function will `require' them too---but not error if they don't | ||
57 | exist." | ||
58 | (dolist (feat features) | ||
59 | (apply #'require (ensure-list feat)) | ||
60 | (require (intern (format "+%s" feat)) nil :noerror))) | ||
61 | |||
62 | ;;; Improvements to default functions | ||
63 | |||
64 | (defun +save-buffers-kill-terminal (arg) | ||
65 | "Delete the current frame, or quit Emacs. | ||
66 | This function is my customization of `save-buffers-kill-terminal'." | ||
67 | (interactive "P") | ||
68 | (cond (arg (delete-frame nil :force)) | ||
69 | ((= 1 (length (frame-list))) | ||
70 | (and (yes-or-no-p "Kill emacs? ") | ||
71 | (save-buffers-kill-emacs t))) | ||
72 | (:else (delete-frame)))) | ||
73 | |||
74 | (defun really-quit-emacs (arg) | ||
75 | "Really, actually quit Emacs." | ||
76 | (interactive "P") | ||
77 | (cond (arg (save-buffers-kill-emacs t)) | ||
78 | (:else (save-buffers-kill-terminal t)))) | ||
79 | |||
80 | (defun +cycle-spacing (&optional n) | ||
81 | ;; `cycle-spacing' is wildly different in 29.1 over 28. | ||
82 | "Negate N argument on `cycle-spacing'. | ||
83 | That is, with a positive N, deletes newlines as well, leaving -N | ||
84 | spaces. If N is negative, it will not delete newlines and leave | ||
85 | N spaces." | ||
86 | (interactive "*p") | ||
87 | (cycle-spacing (- n))) | ||
88 | |||
89 | (defun delete-window|bury-buffer () | ||
90 | "Delete the current window, or bury the current buffer. | ||
91 | If the current window is the only window, bury the buffer." | ||
92 | (interactive) | ||
93 | (condition-case e | ||
94 | (delete-window) | ||
95 | (t (bury-buffer)))) | ||
96 | |||
97 | (defun other-window|switch-buffer (arg) | ||
98 | "Call `other-window' or `switch-buffer' depending on windows. | ||
99 | When called with prefix ARG, unconditionally switch buffer." | ||
100 | (interactive "P") | ||
101 | (if (or arg (one-window-p)) | ||
102 | (switch-to-buffer (other-buffer) nil t) | ||
103 | (other-window 1))) | ||
104 | |||
105 | (defun open-paragraph (&optional arg) | ||
106 | "Open a paragraph after paragraph at point. | ||
107 | A paragraph is defined as continguous non-empty lines of text | ||
108 | surrounded by empty lines, so opening a paragraph means to make | ||
109 | three blank lines, then place the point on the second one. | ||
110 | |||
111 | Called with prefix ARG, open a paragraph before point." | ||
112 | ;; TODO: Take an integer as ARG, allowing for skipping paragraphs up and down. | ||
113 | (interactive "*P") | ||
114 | ;; Go to next blank line. This /isn't/ `end-of-paragraph-text' because | ||
115 | ;; that's weird with org, and I'm guessing other modes too. | ||
116 | (unless (looking-at "^$") (forward-line (if arg -1 +1))) | ||
117 | (while (and (not (looking-at "^$")) | ||
118 | (= 0 (forward-line (if arg -1 +1))))) | ||
119 | (newline) | ||
120 | (when arg (newline) (forward-line -2)) | ||
121 | (delete-blank-lines) | ||
122 | (newline 2) | ||
123 | (previous-line)) | ||
124 | |||
125 | (defun +initial-buffer () | ||
126 | (if (equal (get-buffer "*Messages*") | ||
127 | (other-buffer)) | ||
128 | (get-buffer "*scratch*") | ||
129 | (other-buffer))) | ||
130 | |||
131 | (defun open-paragraph (&optional arg) | ||
132 | "Open a paragraph after paragraph at point. | ||
133 | A paragraph is defined as continguous non-empty lines of text | ||
134 | surrounded by empty lines, so opening a paragraph means to make | ||
135 | three blank lines, then place the point on the second one. | ||
136 | |||
137 | Called with prefix ARG, open a paragraph before point." | ||
138 | ;; TODO: Take an integer as ARG, allowing for skipping paragraphs up and down. | ||
139 | (interactive "*P") | ||
140 | ;; Go to next blank line. This /isn't/ `end-of-paragraph-text' because | ||
141 | ;; that's weird with org, and I'm guessing other modes too. | ||
142 | (unless (looking-at "^$") (forward-line (if arg -1 +1))) | ||
143 | (while (and (not (looking-at "^$")) | ||
144 | (= 0 (forward-line (if arg -1 +1))))) | ||
145 | (newline) | ||
146 | (when arg (newline) (forward-line -2)) | ||
147 | (delete-blank-lines) | ||
148 | (newline 2) | ||
149 | (previous-line)) | ||
150 | |||
151 | (defun create-missing-directories () | ||
152 | "Automatically create missing directories when finding a file." | ||
153 | ;; https://emacsredux.com/blog/2022/06/12/auto-create-missing-directories/ | ||
154 | (let ((target-dir (file-name-directory buffer-file-name))) | ||
155 | (unless (file-exists-p target-dir) | ||
156 | (make-directory target-dir t)))) | ||
157 | |||
158 | (defun +vc-off@remote () | ||
159 | (when (file-remote-p (buffer-file-name)) | ||
160 | (setq-local vc-handled-backends nil))) | ||
161 | |||
162 | (defun +auto-save-some-buffers (&rest _) | ||
163 | "Quietly run `save-some-buffers'." | ||
164 | (let ((inhibit-message t)) | ||
165 | (with-temp-message "" | ||
166 | (save-some-buffers t)))) | ||
167 | |||
168 | (defun comment-lines (str &optional comment-char) | ||
169 | "Comment each line of STR. | ||
170 | Returns the new, commented, string. | ||
171 | |||
172 | If COMMENT-CHAR is missing or nil, use `comment-start'." | ||
173 | (mapconcat (lambda (ln) | ||
174 | (concat (or comment-char comment-start) | ||
175 | ln)) | ||
176 | (string-lines str) | ||
177 | "\n")) | ||
178 | |||
179 | (defun clamp (value min max) | ||
180 | "Clamp VALUE between MIN and MAX." | ||
181 | (min max (max min value))) | ||
182 | |||
183 | (define-minor-mode truncate-lines-local-mode | ||
184 | "Truncate lines locally in a buffer." | ||
185 | :lighter " ..." | ||
186 | :group 'display | ||
187 | (setq-local truncate-lines truncate-lines-local-mode)) | ||
188 | |||
189 | (defun mapc-buffers (func &optional predicate) | ||
190 | "Map FUNC over buffers matching PREDICATE. | ||
191 | Both FUNC and PREDICATE will be executed with no arguments and in | ||
192 | the context of each buffer. | ||
193 | |||
194 | If PREDICATE is nil or not given, map FUNC over all buffers." | ||
195 | (cl-loop for buf being the buffers | ||
196 | do (with-current-buffer buf | ||
197 | (when (and predicate | ||
198 | (funcall predicate)) | ||
199 | (funcall func))))) | ||
200 | |||
201 | (defun mapc-buffers-modes (func &rest modes) | ||
202 | "Map FUNC over buffers derived from MODES. | ||
203 | FUNC will be executed with no arguments and in the context of | ||
204 | each buffer." | ||
205 | (mapc-buffers func | ||
206 | (lambda () | ||
207 | (apply #'derived-mode-p modes)))) | ||
208 | |||
209 | (defun ++concat (func strings) | ||
210 | "Concat STRINGS processed by FUNC. | ||
211 | Each of STRINGS can be a bare string or a list. Strings are | ||
212 | passed through as-is, but lists are passed to FUNC first as | ||
213 | arguments. Finally, all the resulting strings are `mapconcat'-ed | ||
214 | together. | ||
215 | |||
216 | As a special case, if `:separator' is the first of STRINGS, the | ||
217 | string following will be used as a separator. Otherwise, a | ||
218 | newline will be used." | ||
219 | (let (separator) | ||
220 | (when (eq (car strings) :separator) | ||
221 | (setq separator (cadr strings) | ||
222 | strings (cddr strings))) | ||
223 | (mapconcat (lambda (s) | ||
224 | (cond | ||
225 | ((listp s) (apply func s)) | ||
226 | ((stringp s) s) | ||
227 | (t (user-error "Bad argument: %S" s)))) | ||
228 | strings | ||
229 | (or separator "\n")))) | ||
230 | |||
231 | (defun nconcat (&rest strings) | ||
232 | "Concat STRINGS separated by SEPARATOR. | ||
233 | If `:separator' is the first of STRINGS, the next string will be used to | ||
234 | separate the rest of STRINGS." | ||
235 | (++concat #'concat strings)) | ||
236 | |||
237 | (defun format-concat (&rest strings) | ||
238 | "Concatenate formatted STRINGS. | ||
239 | Each of STRINGS can be a bare string or a list. Bare strings are passed as-is | ||
240 | to `mapconcat' for concatenation and separation. Lists, however, are passed to | ||
241 | `format' first. | ||
242 | |||
243 | If `:separator' is the first of STRINGS, the next string will be | ||
244 | used as a separator." | ||
245 | (++concat #'format strings)) | ||
246 | |||
247 | (defun choose-executable (&rest programs) | ||
248 | "Return the first of PROGRAMS that exists in the system's $PATH." | ||
249 | (seq-some #'executable-find programs)) | ||
250 | |||
251 | ;;; Update packages more better-er | ||
252 | |||
253 | (defun +package-update-all () | ||
254 | "Update all packages and vc packages." | ||
255 | (interactive) | ||
256 | (package-update-all) | ||
257 | ;; WTF! | ||
258 | (let ((package-archives-nil)) | ||
259 | (package-vc-update-all))) | ||
260 | |||
261 | (provide 'acdw-funs) | ||
262 | ;;; acdw-funs.el ends here | ||
diff --git a/lisp/acdw-macs.el b/lisp/acdw-macs.el new file mode 100644 index 0000000..e2258fa --- /dev/null +++ b/lisp/acdw-macs.el | |||
@@ -0,0 +1,293 @@ | |||
1 | ;;; acdw-macs.el --- extra macros -*- lexical-binding: t; -*- | ||
2 | |||
3 | (eval-when-compile | ||
4 | (require 'cl-lib) | ||
5 | (require 'tempo) | ||
6 | (declare-function derived-mode-abbrev-table-name "tempo")) | ||
7 | |||
8 | ;;; Extra functionality for `eval-after-load' | ||
9 | |||
10 | (defun eval-after-init (thunk) | ||
11 | "Evaluate THUNK after Emacs initiation, or now if already initialized." | ||
12 | (if after-init-time | ||
13 | (funcall thunk) | ||
14 | (add-hook 'after-init-hook thunk))) | ||
15 | |||
16 | (defmacro eval-after (prereqs &rest body) | ||
17 | "Evaluate body after PREREQS. | ||
18 | PREREQS can be a feature, a number, `t', or a list of those. | ||
19 | |||
20 | Features are used as arguments to `eval-after-load'. Numbers are | ||
21 | used as arguments to `run-with-idle-timer'. `t' will ensure BODY | ||
22 | runs after Emacs's init time. | ||
23 | |||
24 | When given a list of PREREQS, `eval-after' will nest each one | ||
25 | from left to right." | ||
26 | (declare (indent 1) (debug (form def-body))) | ||
27 | (setf prereqs (ensure-list prereqs)) | ||
28 | (if (null prereqs) | ||
29 | (macroexp-progn body) | ||
30 | (let* ((this (car prereqs)) | ||
31 | (form `((lambda () (eval-after ,(cdr prereqs) ,@body))))) | ||
32 | (cond | ||
33 | ((eq this :init) | ||
34 | (append '(eval-after-init) form)) | ||
35 | ((numberp this) | ||
36 | (append `(run-with-idle-timer ,this nil) form)) | ||
37 | ((symbolp this) | ||
38 | (append `(eval-after-load ',this) form)) | ||
39 | (:else (user-error "Eval-after: Bad prereq: %S" this)))))) | ||
40 | |||
41 | |||
42 | ;;; Easier customization of options | ||
43 | ;; At some point it might be nice to include more forms in the VAR slots, like | ||
44 | ;; `setup's `:option' macro. | ||
45 | |||
46 | (if (fboundp 'setopt) | ||
47 | ;; Emacs 29 introduces `setopt', which does basically the same thing as the | ||
48 | ;; macro below. Not exactly the same, of course---it uses `setopt--set' | ||
49 | ;; instead of `customize-set-variable'---but I'm going to trust the Emacs | ||
50 | ;; devs on this one. | ||
51 | (defalias 'setc 'setopt) | ||
52 | (defmacro setc (&rest args) | ||
53 | "Customize user options in a `setq'-like way." | ||
54 | (declare (debug setq)) | ||
55 | (unless (zerop (mod (length args) 2)) | ||
56 | (signal 'wrong-number-of-arguments `(evenp ,(length args)))) | ||
57 | (let (form defuns) | ||
58 | (while args | ||
59 | (let* ((var (pop args)) | ||
60 | (val (pop args))) | ||
61 | (when (memq (car-safe val) '(defun defmacro)) | ||
62 | (push val defuns) | ||
63 | (setq val `(function ,(cadr val)))) | ||
64 | (push `(customize-set-variable ',var ,val "Set by `setc'.") | ||
65 | form))) | ||
66 | `(progn ,@(append (nreverse defuns) (nreverse form)))))) | ||
67 | |||
68 | |||
69 | ;;; Extra def- forms | ||
70 | |||
71 | (defmacro defdir (name directory &optional docstring) | ||
72 | "Define a variable and a function NAME expanding to DIRECTORY. | ||
73 | DOCSTRING is applied to the variable; its default is DIRECTORY's | ||
74 | path." | ||
75 | (declare (indent 2) (doc-string 3)) | ||
76 | `(progn | ||
77 | (defvar ,name ,directory | ||
78 | ,(concat (or docstring (format "%s" directory)) "\n" | ||
79 | "Defined by `defdir'.")) | ||
80 | (defun ,name (file &optional mkdir) | ||
81 | ,(concat "Expand FILE relative to variable `" (symbol-name name) "'.\n" | ||
82 | "If MKDIR is non-nil, parent directories are created.\n" | ||
83 | "Defined by `defdir'.") | ||
84 | (let ((file-name (expand-file-name | ||
85 | (convert-standard-filename file) ,name))) | ||
86 | (when mkdir | ||
87 | (make-directory (file-name-directory file-name) :parents)) | ||
88 | file-name)))) | ||
89 | |||
90 | (defmacro defkeys (maps &rest bindings) | ||
91 | "Define key BINDINGS in MAPS. | ||
92 | If MAPS is nil or t, bind to `current-global-map'. Otherwise, | ||
93 | bind each of BINDINGS to the map or list of maps provided. | ||
94 | |||
95 | BINDINGS is a `setq'-style list of pairs of keys and definitions. | ||
96 | The key part of each binding can be a string, in which case it's | ||
97 | passed to `kbd', or a vector or anything else `define-key' | ||
98 | accepts in the KEY position. The definition part, likewise, can | ||
99 | be any form `define-key' accepts in that position, with this | ||
100 | addition: if the form is a `defun' form, it will be defined | ||
101 | before any keys are bound." | ||
102 | (declare (indent 1)) | ||
103 | (unless (cl-evenp (length bindings)) | ||
104 | (signal 'wrong-number-of-arguments `(evenp ,(length bindings)))) | ||
105 | `(progn | ||
106 | ,@(cl-loop | ||
107 | for map in (ensure-list maps) | ||
108 | for first-map-p = t then nil | ||
109 | append | ||
110 | (cl-loop | ||
111 | for (keys def) on bindings by #'cddr | ||
112 | for defp = (memq (car-safe def) '(defmap defun defmacro)) | ||
113 | if (and defp first-map-p) collect def into defuns | ||
114 | append | ||
115 | (cl-loop | ||
116 | for key in (ensure-list keys) | ||
117 | collect (list 'define-key | ||
118 | (if (memq map '(t nil)) | ||
119 | '(current-global-map) | ||
120 | (or (car-safe map) map)) | ||
121 | (if (stringp key) | ||
122 | `(kbd ,key) | ||
123 | key) | ||
124 | (if defp | ||
125 | (cl-case (car def) | ||
126 | ((defmap) (cadr def)) | ||
127 | ((defun defmacro) `#',(cadr def)) | ||
128 | (otherwise (error "Bad def type: %S" | ||
129 | (car def)))) | ||
130 | def))) | ||
131 | into keydefs | ||
132 | finally return | ||
133 | (let ((all (append defuns keydefs))) | ||
134 | (if-let ((after (plist-get (cdr-safe map) :after))) | ||
135 | `((eval-after ,after | ||
136 | ,@all)) | ||
137 | all)))))) | ||
138 | |||
139 | (defmacro defmap (name docstring &rest bindings) | ||
140 | "Define a keymap named NAME, with BINDINGS." | ||
141 | (declare (indent 1) (doc-string 2)) | ||
142 | `(,(if (boundp name) 'setq 'defvar) ,name | ||
143 | ;;; ^ probably a terrible hack | ||
144 | (let ((map (make-sparse-keymap))) | ||
145 | (defkeys map ,@bindings) | ||
146 | map) | ||
147 | ,@(unless (boundp name) (list docstring)))) | ||
148 | |||
149 | (defmacro defhook (hooks &rest body) | ||
150 | "Define a function to hook into HOOKS. | ||
151 | NAME and ARGS are passed to the generated `defun' form. | ||
152 | Each hook in HOOKS can be the name of a hook or a list of the form | ||
153 | (HOOK DEPTH LOCAL), where each argument is the same as in | ||
154 | `add-hook'." | ||
155 | (declare (indent 1)) | ||
156 | (let* ((name (or (plist-get body :name) | ||
157 | (intern (format "%s/h" | ||
158 | (mapconcat | ||
159 | (lambda (h) | ||
160 | (string-remove-suffix | ||
161 | "-hook" | ||
162 | (if (and (consp h) | ||
163 | (caddr h)) | ||
164 | (format "%s:local" (car h)) | ||
165 | (format "%s" (or (car-safe h) | ||
166 | h))))) | ||
167 | (ensure-list hooks) | ||
168 | "|"))))) | ||
169 | (args (or (plist-get body :args) nil)) | ||
170 | (doc (or (plist-get body :doc) nil)) | ||
171 | (forms ; (DEFUN . FUNCS) | ||
172 | (cl-loop for form in (delete2 body :name :args :doc) | ||
173 | if (eq (car form) 'function) | ||
174 | collect form into funcs | ||
175 | else collect form into defuns | ||
176 | finally return (cons defuns funcs))) | ||
177 | (defun-forms (car forms)) | ||
178 | (func-forms (cdr forms))) | ||
179 | `(progn | ||
180 | ,@(when defun-forms | ||
181 | `((defun ,name ,args ,@(when doc (list doc)) ,@defun-forms))) | ||
182 | ,@(cl-loop for hook in (ensure-list hooks) | ||
183 | for h = (or (car-safe hook) hook) | ||
184 | for ha = (cdr-safe hook) | ||
185 | if defun-forms | ||
186 | collect `(add-hook ',h #',name ,@ha) | ||
187 | append | ||
188 | (cl-loop for fn in func-forms | ||
189 | collect `(add-hook ',h ,fn ,@ha)))))) | ||
190 | |||
191 | ;; (autoload FUNCTION FILE &optional DOCSTRING INTERACTIVE TYPE) | ||
192 | (defmacro defautoload (file &rest fns) | ||
193 | "Autoload FNS from FILE. | ||
194 | Each of FNS can be an atom (function name) or a list of the | ||
195 | form (FUNCTION ARGS), where ARGS is a plist. ARGS's possible | ||
196 | keys are `:doc' (docstring), `:interactive', and `:type', which are | ||
197 | used as the optional arguments to `autoload'. | ||
198 | |||
199 | You can also pass `:interactive' and `:type' as keyword arguments | ||
200 | just after FILE, and they'll serve as the default for the | ||
201 | autoloaded FNS." | ||
202 | (declare (indent 1)) | ||
203 | (let ((interactive (plist-get fns :interactive)) | ||
204 | (type (plist-get fns :type)) | ||
205 | (fns (delete2 fns :interactive :type))) | ||
206 | `(progn | ||
207 | ,@(cl-loop for fn in fns | ||
208 | for name = (or (car-safe fn) fn) | ||
209 | for args = (cdr-safe fn) | ||
210 | collect | ||
211 | `(autoload ',name ,(format "%s" file) | ||
212 | ,(plist-get args :doc) | ||
213 | ,(or (plist-get args :interactive) | ||
214 | interactive) | ||
215 | ,(or (plist-get args :type) | ||
216 | type)))))) | ||
217 | |||
218 | |||
219 | ;;; Miscellaneous | ||
220 | |||
221 | (defmacro with-message (message &rest body) | ||
222 | "Display MESSAGE then execute BODY. | ||
223 | If BODY executes without errors, display MESSAGE...done." | ||
224 | (declare (indent 1)) | ||
225 | (let ((msym (gensym)) | ||
226 | (esym (gensym))) | ||
227 | `(let ((,msym ,message)) | ||
228 | (condition-case ,esym | ||
229 | (progn (message "%s..." ,msym) | ||
230 | ,@body) | ||
231 | (:success (message "%s...done" ,msym)) | ||
232 | (t (signal (car ,esym) (cdr ,esym))))))) | ||
233 | |||
234 | (defmacro o (&rest fns) | ||
235 | "Compose FNS into a new function for one argument." | ||
236 | (if (null fns) | ||
237 | `(lambda (&rest args) args) | ||
238 | `(lambda (&rest args) | ||
239 | (apply | ||
240 | #',(car fns) | ||
241 | (ensure-list (apply (o ,@(cdr fns)) args)))))) | ||
242 | |||
243 | (defmacro with-region-or-buffer (&rest funcs) | ||
244 | "Advise FUNCS with `advise-region-or-buffer'." | ||
245 | `(progn | ||
246 | ,@(cl-loop for fn in funcs | ||
247 | collect | ||
248 | `(advice-add ',fn :before #'advise-region-or-buffer)))) | ||
249 | |||
250 | (defmacro with-region-or-line (&rest funcs) | ||
251 | "Advise FUNCS with `advise-region-or-line'." | ||
252 | `(progn | ||
253 | ,@(cl-loop for fn in funcs | ||
254 | collect | ||
255 | `(advice-add ',fn :before #'advise-region-or-line)))) | ||
256 | |||
257 | (defmacro with-region-or-to-eol (&rest funcs) | ||
258 | "Advise FUNCS with `advise-region-or-to-eol'." | ||
259 | `(progn | ||
260 | ,@(cl-loop for fn in funcs | ||
261 | collect | ||
262 | `(advice-add ',fn :before #'advise-region-or-to-eol)))) | ||
263 | |||
264 | (defmacro define-tempo (tag doc &rest elements) | ||
265 | "Define a template and add its tag to MODE's abbrev-table. | ||
266 | TAG, DOC, and ELEMENTS are passed to `tempo-define-template', which see. | ||
267 | ABBREV, if given, is the abbrev string to use for template expansion | ||
268 | under MODE's abbrev-table. If ABBREV isn't given, TAG will be used." | ||
269 | (declare (indent 1)) | ||
270 | (let* ((template (gensym)) | ||
271 | (tag (cond ((stringp tag) tag) | ||
272 | ((symbolp tag) (symbol-name tag)) | ||
273 | (t (user-error "TAG must be a string or symbol: %S" tag)))) | ||
274 | (mode (or (plist-get elements :mode) nil)) | ||
275 | (abbrev (or (plist-get elements :abbrev) tag)) | ||
276 | (taglist (or (plist-get elements :taglist) nil)) | ||
277 | (table (let ((tname (and mode (derived-mode-abbrev-table-name mode)))) | ||
278 | (while (and tname (not (memq tname abbrev-table-name-list))) | ||
279 | (setq tname (and (get mode 'derived-mode-parent) | ||
280 | (derived-mode-abbrev-table-name | ||
281 | (get mode 'derived-mode-parent))))) | ||
282 | (or tname 'global-abbrev-table))) | ||
283 | (elements (delete2 elements :mode :abbrev :taglist))) | ||
284 | `(let ((,template (tempo-define-template ,tag | ||
285 | ',elements | ||
286 | ,(or abbrev tag) | ||
287 | ,doc | ||
288 | ,taglist))) | ||
289 | (define-abbrev ,table ,tag "" ,template :system t) | ||
290 | (put ,template 'no-self-insert t)))) | ||
291 | |||
292 | (provide 'acdw-macs) | ||
293 | ;;; acdw-macs.el ends here | ||
diff --git a/lisp/acdw.el b/lisp/acdw.el index a9ef893..30c4f44 100644 --- a/lisp/acdw.el +++ b/lisp/acdw.el | |||
@@ -1,272 +1,79 @@ | |||
1 | ;;; acdw.el -- bits and bobs -*- lexical-binding: t; -*- | 1 | ;;; acdw.el --- Basic emacs shit for acdw -*- lexical-binding: t -*- |
2 | ;; by C. Duckworth <acdw@acdw.net> | 2 | |
3 | (require 'cl-lib) | 3 | ;;; Code: |
4 | ;; def.el is here | 4 | |
5 | (require 'def) | 5 | (require 'acdw-funs) ; Extra functions |
6 | 6 | (require 'acdw-macs) ; Extra macros | |
7 | ;;; Define both a directory and a function expanding to a file in that directory | 7 | |
8 | 8 | (defdir etc/ (locate-user-emacs-file "etc") | |
9 | (defmacro +define-dir (name directory &optional docstring inhibit-mkdir) | 9 | "Directory for package configuration files. |
10 | "Define a variable and function NAME expanding to DIRECTORY. | 10 | See `no-littering' for examples.") |
11 | DOCSTRING is applied to the variable. Ensure DIRECTORY exists in | 11 | |
12 | the filesystem, unless INHIBIT-MKDIR is non-nil." | 12 | (defdir var/ etc/ |
13 | (declare (indent 2) | 13 | "Directory for package data file. |
14 | (doc-string 3)) | 14 | See `no-littering' for examples.") |
15 | (unless inhibit-mkdir | 15 | |
16 | (make-directory (eval directory) :parents)) | 16 | (defdir cache/ (if-let ((xdg-cache (getenv "XDG_CACHE_HOME"))) |
17 | `(progn | 17 | (expand-file-name "emacs/" xdg-cache) |
18 | (defvar ,name ,directory | 18 | etc/) |
19 | ,(concat docstring (when docstring "\n") | 19 | "Directory for cache files.") |
20 | "Defined by `/define-dir'.")) | 20 | |
21 | (defun ,name (file &optional mkdir) | 21 | (setq native-compile-target-directory (cache/ "eln" t)) |
22 | ,(concat "Expand FILE relative to variable `" (symbol-name name) "'.\n" | 22 | (when (fboundp 'startup-redirect-eln-cache) |
23 | "If MKDIR is non-nil, the directory is created.\n" | 23 | (startup-redirect-eln-cache (cache/ "eln" t))) |
24 | "Defined by `/define-dir'.") | 24 | |
25 | (let ((file-name (expand-file-name (convert-standard-filename file) | 25 | (defdir sync/ (expand-file-name "/home/case/Sync") |
26 | ,name))) | 26 | "My Syncthing directory.") |
27 | (when mkdir | 27 | |
28 | (make-directory (file-name-directory file-name) :parents)) | 28 | (defdir private/ (sync/ "emacs/private")) |
29 | file-name)))) | 29 | (add-to-list 'load-path private/) |
30 | 30 | ||
31 | ;;; Evaluating things after other things | 31 | (require 'acdw-defaults) ; Sane defaults |
32 | 32 | (require '_acdw) ; Private stuff | |
33 | (defun eval-after-init (fn) | 33 | (require '+lisp) ; Lispy goodness |
34 | "Evaluate FN after inititation, or now if Emacs is initialized. | 34 | |
35 | FN is called with no arguments." | 35 | (setc enable-recursive-minibuffers t |
36 | (if after-init-time | 36 | completions-detailed t |
37 | (funcall fn) | 37 | completion-ignore-case t |
38 | (add-hook 'after-init-hook fn))) | 38 | read-buffer-completion-ignore-case t |
39 | 39 | read-file-name-completion-ignore-case t | |
40 | (defmacro eval-after (features &rest body) | 40 | initial-buffer-choice #'+initial-buffer |
41 | "Evaluate BODY, but only after loading FEATURES. | 41 | initial-scratch-message |
42 | FEATURES can be an atom or a list; as an atom it works like | 42 | (format "%s\n\n" |
43 | `with-eval-after-load'. The special feature `init' will evaluate | 43 | (comment-lines |
44 | BODY after Emacs is finished initializing." | 44 | (shell-command-to-string "fortune") |
45 | (declare (indent 1) | 45 | ";; ")) |
46 | (debug (form def-body))) | 46 | sentence-end-double-space nil |
47 | (unless (listp features) | 47 | save-silently t) |
48 | (setf features (list features))) | 48 | |
49 | (if (null features) | 49 | (defkeys t |
50 | (macroexp-progn body) | 50 | "M-o" #'other-window|switch-buffer |
51 | (let* ((this (car features)) | 51 | "C-x 0" #'delete-window|bury-buffer |
52 | (rest (cdr features))) | 52 | "C-M-;" #'+lisp-comment-or-uncomment-sexp |
53 | (cond ((eq this 'init) | 53 | "M-SPC" #'+cycle-spacing |
54 | `(eval-after-init | 54 | "C-x C-k" #'kill-this-buffer) |
55 | (lambda () (eval-after ,rest ,@body)))) | 55 | |
56 | (:else | 56 | (defkeys t |
57 | `(with-eval-after-load ',this | 57 | "M-u" #'universal-argument) |
58 | (eval-after ,rest ,@body))))))) | 58 | |
59 | 59 | (defkeys universal-argument-map | |
60 | ;;; Convenience functions | 60 | "M-u" #'universal-argument-more) |
61 | 61 | ||
62 | (defun define-key* (maps &rest keydefs) | 62 | (define-advice switch-to-buffer (:after (&rest _) normal-mode) |
63 | "Define KEYDEFS in MAPS. | 63 | "Automatically determine the mode for created non-file buffers." |
64 | Convenience wrapper around `define-key'." | 64 | (when-let ((_ (and (eq major-mode 'fundamental-mode))) |
65 | (unless (zerop (mod (length keydefs) 2)) | 65 | (buffer-file-name (buffer-name))) |
66 | (user-error "Wrong number of arguments: %S" (length keydefs))) | 66 | (normal-mode))) |
67 | (dolist (map (if (or (atom maps) (eq (car maps) 'keymap)) | 67 | |
68 | (list maps) | 68 | (define-advice canonically-space-region |
69 | maps)) | 69 | (:around (orig &rest args) double-space-sentences) |
70 | (cl-loop for (key def) on keydefs by #'cddr | 70 | (let ((sentence-end-double-space t)) |
71 | do (let ((key (if (stringp key) (kbd key) key))) | 71 | (apply orig args))) |
72 | (define-key (if (symbolp map) | 72 | |
73 | (symbol-value map) | 73 | (with-region-or-buffer indent-region) |
74 | map) | 74 | |
75 | key def))))) | 75 | (winner-mode) |
76 | |||
77 | (unless (fboundp 'ensure-list) | ||
78 | ;; Just in case we're using an old version of Emacs. | ||
79 | (defun ensure-list (object) | ||
80 | "Return OBJECT as a list. | ||
81 | If OBJECT is already a list, return OBJECT itself. If it's | ||
82 | not a list, return a one-element list containing OBJECT." | ||
83 | (if (listp object) | ||
84 | object | ||
85 | (list object)))) | ||
86 | |||
87 | (defun add-to-list* (lists &rest things) | ||
88 | "Add THINGS to LISTS. | ||
89 | LISTS can be one list variable or a list. Each thing of THINGS | ||
90 | can be either a variable (the thing), or a list of the form | ||
91 | (ELEMENT &optional APPEND COMPARE-FN), which is passed to | ||
92 | `add-to-list'." | ||
93 | (declare (indent 1)) | ||
94 | (dolist (l (ensure-list lists)) | ||
95 | (dolist (thing things) | ||
96 | (apply #'add-to-list l (ensure-list thing))))) | ||
97 | |||
98 | (defun add-hook* (hooks &rest functions) | ||
99 | "Add FUNCTIONS to HOOKS. | ||
100 | Each function in FUNCTIONS can be a singleton or a list of the | ||
101 | form (FUNCTION &optional DEPTH LOCAL)." | ||
102 | (declare (indent 1)) | ||
103 | (dolist (hook (ensure-list hooks)) | ||
104 | (dolist (fn functions) | ||
105 | (apply #'add-hook hook (ensure-list fn))))) | ||
106 | |||
107 | (defun +concat (&rest strings) | ||
108 | "Concat STRINGS separated by SEPARATOR. | ||
109 | SEPARATOR is \"\\n\" unless the keyword argument `:separator' is | ||
110 | given, followed by the separator to use. Each item in STRINGS is | ||
111 | either a string or a list or strings, which is concatenated | ||
112 | without any separator." | ||
113 | (let (ret | ||
114 | ;; I don't know why a `cl-defun' with | ||
115 | ;; (&rest strings &key (separator "\n")) doesn't work | ||
116 | (separator (or (cl-loop for i from 0 upto (length strings) | ||
117 | if (eq (nth i strings) :separator) | ||
118 | return (nth (1+ i) strings)) | ||
119 | "\n"))) | ||
120 | (while strings | ||
121 | (let ((string (pop strings))) | ||
122 | (cond ((eq string :separator) (pop strings)) | ||
123 | ((listp string) (push (apply #'concat string) ret)) | ||
124 | ((stringp string) (push string ret))))) | ||
125 | (mapconcat #'identity (nreverse ret) separator))) | ||
126 | |||
127 | (defun require* (&rest features) | ||
128 | "Require FEATURES in order. | ||
129 | Each feature of FEATURES can also be a list of the arguments to | ||
130 | pass to `require', which see." | ||
131 | (condition-case e | ||
132 | (dolist (feature features) | ||
133 | (apply #'require (ensure-list feature))) | ||
134 | (:success (mapcar (lambda (f) (car (ensure-list f))) features)) | ||
135 | (t (signal (car e) (cdr e))))) | ||
136 | |||
137 | ;;; Convenience macros | ||
138 | |||
139 | (defmacro define-local-before-save-hook (mode-or-hook &rest body) | ||
140 | "Add a local `before-save-hook' to MODE-OR-HOOK." | ||
141 | (declare (indent 1)) | ||
142 | (let* ((name (format "%s" mode-or-hook)) | ||
143 | (external-name (intern (format "%s@before-save" name))) | ||
144 | (internal-name (intern (format "before-save@%s" name))) | ||
145 | (hook (if (string-suffix-p "-hook" name) | ||
146 | mode-or-hook | ||
147 | (intern (format "%s-hook" name))))) | ||
148 | `(progn | ||
149 | (defun ,internal-name () | ||
150 | ,@body) | ||
151 | (defun ,external-name () | ||
152 | (add-hook 'before-save-hook #',internal-name nil :local)) | ||
153 | (add-hook ',hook #',external-name)))) | ||
154 | |||
155 | (defmacro setq-local-hook (hooks &rest args) | ||
156 | "Run `setq-local' on ARGS when running HOOKs." | ||
157 | ;; FIXME: this is pretty messy, i think... | ||
158 | ;; The settings should be stored in an alist so that they can be deduplicated | ||
159 | (declare (indent 1)) | ||
160 | `(progn | ||
161 | ,@(cl-loop for hook in (ensure-list hooks) | ||
162 | collect | ||
163 | (let ((fn (intern (format "%s-setq-local" hook)))) | ||
164 | (when (and (fboundp fn) | ||
165 | (functionp fn)) | ||
166 | (setf args (append (function-get fn 'setq-local-hook-settings) args))) | ||
167 | (unless (and (< 0 (length args)) | ||
168 | (zerop (mod (length args) 2))) | ||
169 | (user-error "Wrong number of arguments: %S" (length args))) | ||
170 | `(progn | ||
171 | (defun ,fn () | ||
172 | ,(format "Set local variables after `%s'." hook) | ||
173 | (setq-local ,@args)) | ||
174 | (function-put ',fn 'setq-local-hook-settings ',args) | ||
175 | (dolist (buf (buffer-list)) | ||
176 | (with-current-buffer buf | ||
177 | (when (derived-mode-p | ||
178 | ',(intern (replace-regexp-in-string | ||
179 | "-hook" "" (format "%s" hook)))) | ||
180 | (,fn)))) | ||
181 | (add-hook ',hook #',fn)))))) | ||
182 | |||
183 | (defmacro with-message (message &rest body) | ||
184 | "Execute BODY, with MESSAGE. | ||
185 | If body executes without errors, MESSAGE...Done will be displayed." | ||
186 | (declare (indent 1)) | ||
187 | (let ((msg (gensym))) | ||
188 | `(let ((,msg ,message)) | ||
189 | (condition-case e | ||
190 | (progn (message "%s..." ,msg) | ||
191 | ,@body) | ||
192 | (:success (message "%s...done" ,msg)) | ||
193 | (t (signal (car e) (cdr e))))))) | ||
194 | |||
195 | (defmacro either (&rest clauses) | ||
196 | "Return the first of CLAUSES that returns non-nil." | ||
197 | (let* ((this (gensym "either"))) | ||
198 | (unless (null clauses) | ||
199 | `(let* ((,this ,(car clauses))) | ||
200 | (if ,this ,this (either ,@(cdr clauses))))))) | ||
201 | |||
202 | (defun mapc-buffers (fn &optional pred) | ||
203 | "Perform FN on buffers matching PRED. | ||
204 | If PRED is nil or absent, perform FN on all buffers. Both FN and | ||
205 | PRED are called within a `with-current-buffer' form and without | ||
206 | arguments." | ||
207 | (let ((pred (cond | ||
208 | ((listp pred) | ||
209 | (lambda () (apply #'derived-mode-p pred))) | ||
210 | ((functionp pred) pred) | ||
211 | ((null pred) (lambda () t)) | ||
212 | (:else (user-error "Bad predicate"))))) | ||
213 | (dolist (buf (buffer-list)) | ||
214 | (with-current-buffer buf | ||
215 | (when (funcall pred) | ||
216 | (funcall fn)))))) | ||
217 | |||
218 | ;; https://emacs.stackexchange.com/a/39324/37239 | ||
219 | ;; XXX: This shit don't work rn | ||
220 | (defun ignore-invisible-overlays (fn) | ||
221 | "Execute FN, ignoring invisible overlays. | ||
222 | FN should return a point." | ||
223 | (let ((overlay nil) | ||
224 | (point nil)) | ||
225 | (setq point (and (funcall fn) (point))) | ||
226 | (setq overlay (car (overlays-at (point)))) | ||
227 | (while (and overlay (member 'invisible (overlay-properties overlay))) | ||
228 | (goto-char (overlay-end overlay)) | ||
229 | (setq point (and (funcall fn) (point))) | ||
230 | (setq overlay (car (overlays-at (point))))) | ||
231 | point)) | ||
232 | |||
233 | ;;; Extras | ||
234 | ;; Trying to avoid a whole install of crux ... | ||
235 | |||
236 | (defun kill-and-join-forward (&optional arg) | ||
237 | "Kill the line or, if at the end of a line, join with the next. | ||
238 | This command is `visual-line-mode'-aware. If ARG is provided, | ||
239 | it's passed on to kill a line, but not to delete indentation. | ||
240 | When joining, this command deletes whitespace." | ||
241 | (interactive "P") | ||
242 | (if (and (eolp) (not (bolp))) | ||
243 | (delete-indentation 1) | ||
244 | (funcall (if visual-line-mode #'kill-visual-line #'kill-line) arg))) | ||
245 | |||
246 | (defun other-window|switch-buffer (arg) | ||
247 | "Call `other-window' or `switch-buffer' depending on windows. | ||
248 | When called with prefix ARG, unconditionally switch buffer." | ||
249 | (interactive "P") | ||
250 | (if (or arg (one-window-p)) | ||
251 | (switch-to-buffer (other-buffer) nil t) | ||
252 | (other-window 1))) | ||
253 | |||
254 | ;;; Set variables more better-er | ||
255 | ;; Now this doesn't do `setf'-style stuff. | ||
256 | |||
257 | (defmacro setc (&rest args) | ||
258 | "Customize user options using ARGS like `setq'." | ||
259 | (declare (debug setq)) | ||
260 | (unless (zerop (mod (length args) 2)) | ||
261 | (user-error "Dangling argument: %S" var)) | ||
262 | (let (form) | ||
263 | (while args | ||
264 | (push `(customize-set-variable | ||
265 | ',(pop args) | ||
266 | ,(pop args) | ||
267 | "Set by `setc'.") | ||
268 | form)) | ||
269 | `(progn ,@(nreverse form)))) | ||
270 | 76 | ||
271 | (provide 'acdw) | 77 | (provide 'acdw) |
78 | |||
272 | ;;; acdw.el ends here | 79 | ;;; acdw.el ends here |
diff --git a/lisp/browse-url-transform.el b/lisp/browse-url-transform.el deleted file mode 100644 index c290a1f..0000000 --- a/lisp/browse-url-transform.el +++ /dev/null | |||
@@ -1,45 +0,0 @@ | |||
1 | ;;; browse-url-transform --- transform URLs | ||
2 | |||
3 | (defgroup browse-url-transform nil | ||
4 | "Transformations for urls passed to `browse-url'." | ||
5 | :group 'browse-url) | ||
6 | |||
7 | (defcustom browse-url-transform-alist nil | ||
8 | "Transformation rules for URLs. | ||
9 | The keys are regexps matching URLs, and the values are how to | ||
10 | transform them. The replacements will use match capture data." | ||
11 | :type '(alist :key-type (string :tag "URL regexp match") | ||
12 | :value-type (string :tag "URL regexp transformation"))) | ||
13 | |||
14 | (defun browse-url-transform-url (url) | ||
15 | "Transform URL before passing it to `browse-url'." | ||
16 | (cl-loop with url = (substring-no-properties | ||
17 | (if (consp url) (car url) url)) | ||
18 | for (regex . transformation) in browse-url-transform-alist | ||
19 | if (string-match regex url) | ||
20 | return (replace-match transformation nil nil url) | ||
21 | finally return url)) | ||
22 | |||
23 | (defun browse-url-transform-advice (url &rest args) | ||
24 | "Advice to `browse-url' for URL transformations. | ||
25 | ARGS are passed on for further processing." | ||
26 | (apply #'list (and url (browse-url-transform-url url)) args)) | ||
27 | |||
28 | (define-minor-mode browse-url-transform-mode | ||
29 | "Minor mode to transform a URL before passing it to `browse-url'. | ||
30 | This can be used to \"redirect\" URLs, for example from an | ||
31 | information silo to a more privacy-respecting one (e.g., | ||
32 | \"twitter.com\" -> \"nitter.com\"), by adding advice to `browse-url'. | ||
33 | |||
34 | When using this mode, ensure that the transformed URL is also in | ||
35 | `browse-url-handlers', since that's what `browse-url' will see." | ||
36 | :lighter " Turl" | ||
37 | :keymap nil | ||
38 | :global t | ||
39 | (cond (browse-url-transform-mode | ||
40 | (advice-add 'browse-url :filter-args #'browse-url-transform-advice)) | ||
41 | (:else | ||
42 | (advice-remove 'browse-url #'browse-url-transform-advice)))) | ||
43 | |||
44 | (provide 'browse-url-transform) | ||
45 | ;;; browse-url-transform.el ends here | ||
diff --git a/lisp/dawn.el b/lisp/dawn.el deleted file mode 100644 index 30aab7c..0000000 --- a/lisp/dawn.el +++ /dev/null | |||
@@ -1,109 +0,0 @@ | |||
1 | ;;; dawn.el --- Lightweight dawn/dusk task scheduling -*- lexical-binding: t; -*- | ||
2 | |||
3 | ;; Copyright (C) 2022 Case Duckworth | ||
4 | |||
5 | ;; Author: Case Duckworth | ||
6 | ;; Maintainer: Case Duckworth <acdw@acdw.net> | ||
7 | ;; URL: https://codeberg.org/acdw/dusk.el | ||
8 | ;; Version: 0.3.0 | ||
9 | ;; Keywords: calendar, themes, convenience | ||
10 | ;; Package-Requires: ((emacs "24.3")) | ||
11 | |||
12 | ;;; Commentary: | ||
13 | |||
14 | ;; There is also circadian.el, but it doesn't quite work for me. | ||
15 | ;; This code comes mostly from https://gnu.xyz/auto_theme.html, but also | ||
16 | ;; somewhere else (which I've forgotten) and my own brain :) | ||
17 | |||
18 | ;;; Code: | ||
19 | |||
20 | (require 'calendar) | ||
21 | (require 'cl-lib) | ||
22 | (require 'solar) | ||
23 | |||
24 | ;;; Timers | ||
25 | |||
26 | (defvar dawn--dawn-timer nil | ||
27 | "Timer for dawn-command.") | ||
28 | |||
29 | (defvar dawn--dusk-timer nil | ||
30 | "Timer for dusk-command.") | ||
31 | |||
32 | (defvar dawn--reset-timer nil | ||
33 | "Timer to reset dawn at midnight.") | ||
34 | |||
35 | ;;; Functions | ||
36 | |||
37 | (defun dawn-encode-time (f) | ||
38 | "Encode fractional time F. | ||
39 | If F is nil, return nil." | ||
40 | (when f | ||
41 | (let ((hhmm (cl-floor f)) | ||
42 | (date (cdddr (decode-time)))) | ||
43 | (encode-time | ||
44 | (append (list 0 | ||
45 | (round (* 60 (cadr hhmm))) | ||
46 | (car hhmm)) | ||
47 | date))))) | ||
48 | |||
49 | (defun dawn-midnight () | ||
50 | "Return the time of the /next/ midnight." | ||
51 | (let ((date (cdddr (decode-time)))) | ||
52 | (encode-time | ||
53 | (append (list 0 0 0 (1+ (car date))) (cdr date))))) | ||
54 | |||
55 | (defun dawn-sunrise () | ||
56 | "Return the time of today's sunrise." | ||
57 | (dawn-encode-time (caar (solar-sunrise-sunset (calendar-current-date))))) | ||
58 | |||
59 | (defun dawn-sunset () | ||
60 | "Return the time of today's sunset." | ||
61 | (dawn-encode-time (caadr (solar-sunrise-sunset (calendar-current-date))))) | ||
62 | |||
63 | ;;; Interface | ||
64 | |||
65 | ;;;###autoload | ||
66 | (defun dawn-schedule (dawn-command dusk-command) | ||
67 | "Run DAWN-COMMAND at sunrise, and DUSK-COMMAND at dusk. | ||
68 | Requires `calendar-longitude' and `calendar-latitude' to be set; | ||
69 | if they're not, it will prompt the user for them or error." | ||
70 | (when (or (null calendar-longitude) | ||
71 | (null calendar-latitude)) | ||
72 | (or (solar-setup) | ||
73 | (user-error "`dawn' won't work without setting %s!" | ||
74 | (cond ((and (null calendar-longitude) | ||
75 | (null calendar-latitude)) | ||
76 | "`calendar-longitude' and `calendar-latitude'") | ||
77 | ((null calendar-longitude) | ||
78 | "`calendar-longitude'") | ||
79 | ((null calendar-latitude) | ||
80 | "`calendar-latitude'"))))) | ||
81 | (let ((dawn (dawn-sunrise)) | ||
82 | (dusk (dawn-sunset))) | ||
83 | (cond | ||
84 | ((or (null dawn) (null dusk)) | ||
85 | ;; There is no sunrise or sunset, due to how close we are to the poles. | ||
86 | ;; In this case, we must figure out whether it's day or night. | ||
87 | (pcase (caddr (solar-sunrise-sunset (calendar-current-date))) | ||
88 | ("0:00" (funcall dusk-command)) ; 0 hours of daylight | ||
89 | ("24:00" (funcall dawn-command)) ; 24 hours of daylight | ||
90 | )) | ||
91 | ((time-less-p nil dawn) | ||
92 | ;; If it isn't dawn yet, it's still dark. Run DUSK-COMMAND and schedule | ||
93 | ;; DAWN-COMMAND and DUSK-COMMAND for later. | ||
94 | (funcall dusk-command) | ||
95 | (run-at-time dawn nil dawn-command) | ||
96 | (run-at-time dusk nil dusk-command)) | ||
97 | ((time-less-p nil dusk) | ||
98 | ;; If it isn't dusk yet, it's still light. Run DAWN-COMMAND and schedule | ||
99 | ;; DUSK-COMMAND. | ||
100 | (funcall dawn-command) | ||
101 | (run-at-time dusk nil dusk-command)) | ||
102 | (t ;; Otherwise, it's past dusk, so run DUSK-COMMAND. | ||
103 | (funcall dusk-command))) | ||
104 | ;; Schedule a reset at midnight, to re-calculate dawn/dusk times. | ||
105 | (run-at-time (dawn-midnight) nil | ||
106 | #'dawn-schedule dawn-command dusk-command))) | ||
107 | |||
108 | (provide 'dawn) | ||
109 | ;;; dawn.el ends here | ||
diff --git a/lisp/def.el b/lisp/def.el deleted file mode 100644 index 0bf91b2..0000000 --- a/lisp/def.el +++ /dev/null | |||
@@ -1,142 +0,0 @@ | |||
1 | ;;; def.el --- defining macros -*- lexical-binding: t; -*- | ||
2 | |||
3 | ;;; Code: | ||
4 | |||
5 | (require 'cl-lib) | ||
6 | |||
7 | ;;; Utility | ||
8 | |||
9 | (defun def--assert-args (pred args &optional error-type &rest error-args) | ||
10 | "Assert that ARGS follows PRED. | ||
11 | If it doesn't, raise an error. ERROR-TYPE will be the type of | ||
12 | that error (defaults to `user-error'), and it and ERROR-ARGS are | ||
13 | passed in a list to `signal'." | ||
14 | (unless (funcall pred args) | ||
15 | (funcall #'signal | ||
16 | (or error-type 'user-error) | ||
17 | (or error-args | ||
18 | (list "Wrong arguments" args))))) | ||
19 | |||
20 | (defmacro o (&rest fns) | ||
21 | "Compose FNS into a new function for one argument." | ||
22 | (if (null fns) | ||
23 | `(lambda (&rest args) args) | ||
24 | `(lambda (&rest args) | ||
25 | (apply | ||
26 | #',(car fns) | ||
27 | (ensure-list (apply (o ,@(cdr fns)) args)))))) | ||
28 | |||
29 | ;; TODO: I need to figure out where this function goes. | ||
30 | (defun def--delete2 (list &rest elems) | ||
31 | "Delete each element of ELEMS, and the next item, from LIST." | ||
32 | (let ((r nil)) | ||
33 | (while (consp list) | ||
34 | (if (member (car list) elems) | ||
35 | (setf list (cdr list)) | ||
36 | (setf r (cons (car list) r))) | ||
37 | (setf list (cdr list))) | ||
38 | (reverse r))) | ||
39 | |||
40 | ;;; Keybindings | ||
41 | |||
42 | (defmacro defkeys (maps &rest bindings) | ||
43 | "Define key BINDINGS in MAPS. | ||
44 | If MAPS is nil or t, bind to `current-global-map'. Otherwise, | ||
45 | bind each of BINDINGS to the map or list of maps provided. | ||
46 | |||
47 | BINDINGS is a `setq'-style list of pairs of keys and definitions. | ||
48 | The key part of each binding can be a string, in which case it's | ||
49 | passed to `kbd', or a vector or anything else `define-key' | ||
50 | accepts in the KEY position. The definition part, likewise, can | ||
51 | be any form `define-key' accepts in that position, with this | ||
52 | addition: if the form is a `defun' form, it will be defined | ||
53 | before any keys are bound." | ||
54 | (declare (indent 1)) | ||
55 | (def--assert-args (o cl-evenp length) bindings | ||
56 | 'wrong-number-of-arguments 'defkeys 'evenp (length bindings)) | ||
57 | `(progn | ||
58 | ,@(cl-loop | ||
59 | for map in (ensure-list maps) | ||
60 | for first-map-p = t then nil | ||
61 | append | ||
62 | (cl-loop | ||
63 | for (keys def) on bindings by #'cddr | ||
64 | for defp = (memq (car-safe def) '(defmap defun defmacro)) | ||
65 | if (and defp first-map-p) collect def into defuns | ||
66 | append | ||
67 | (cl-loop | ||
68 | for key in (ensure-list keys) | ||
69 | collect (list 'define-key | ||
70 | (if (memq map '(t nil)) | ||
71 | '(current-global-map) | ||
72 | (or (car-safe map) map)) | ||
73 | (if (stringp key) | ||
74 | `(kbd ,key) | ||
75 | key) | ||
76 | (if defp | ||
77 | (cl-case (car def) | ||
78 | ((defmap) (cadr def)) | ||
79 | ((defun defmacro) `#',(cadr def)) | ||
80 | (otherwise (error "Bad def type: %S" | ||
81 | (car def)))) | ||
82 | def))) | ||
83 | into keydefs | ||
84 | finally return | ||
85 | (let ((all (append defuns keydefs))) | ||
86 | (if-let ((after (plist-get (cdr-safe map) :after))) | ||
87 | `((eval-after ,after | ||
88 | ,@all)) | ||
89 | all)))))) | ||
90 | |||
91 | (defmacro defmap (name docstring &rest bindings) | ||
92 | "Define a keymap named NAME, with BINDINGS." | ||
93 | (declare (indent 1) (doc-string 2)) | ||
94 | `(,(if (boundp name) 'setq 'defvar) ,name | ||
95 | ;;; ^ probably a terrible hack | ||
96 | (let ((map (make-sparse-keymap))) | ||
97 | (defkeys map ,@bindings) | ||
98 | map) | ||
99 | ,@(unless (boundp name) (list docstring)))) | ||
100 | |||
101 | ;;; Hooks | ||
102 | |||
103 | (defmacro defhook (hooks &rest body) | ||
104 | "Define a function to hook into HOOKS. | ||
105 | NAME and ARGS are passed to the generated `defun' form. | ||
106 | Each hook in HOOKS can be the name of a hook or a list of the form | ||
107 | (HOOK DEPTH LOCAL), where each argument is the same as in | ||
108 | `add-hook'." | ||
109 | (declare (indent 1)) | ||
110 | (let* ((name (or (plist-get body :name) | ||
111 | (intern (format "%s/h" | ||
112 | (mapconcat | ||
113 | (lambda (h) | ||
114 | (string-remove-suffix | ||
115 | "-hook" (symbol-name (or (car-safe h) | ||
116 | h)))) | ||
117 | (ensure-list hooks) | ||
118 | "|"))))) | ||
119 | (args (or (plist-get body :args) nil)) | ||
120 | (doc (or (plist-get body :doc) nil)) | ||
121 | (forms ; (DEFUN . FUNCS) | ||
122 | (cl-loop for form in (def--delete2 body :name :args :doc) | ||
123 | if (eq (car form) 'function) | ||
124 | collect form into funcs | ||
125 | else collect form into defuns | ||
126 | finally return (cons defuns funcs))) | ||
127 | (defun-forms (car forms)) | ||
128 | (func-forms (cdr forms))) | ||
129 | `(progn | ||
130 | ,@(when defun-forms | ||
131 | `((defun ,name ,args ,@(when doc (list doc)) ,@defun-forms))) | ||
132 | ,@(cl-loop for hook in (ensure-list hooks) | ||
133 | for h = (or (car-safe hook) hook) | ||
134 | for ha = (cdr-safe hook) | ||
135 | if defun-forms | ||
136 | collect `(add-hook ',h #',name ,@ha) | ||
137 | append | ||
138 | (cl-loop for fn in func-forms | ||
139 | collect `(add-hook ',h ,fn ,@ha)))))) | ||
140 | |||
141 | (provide 'def) | ||
142 | ;;; def.el ends here | ||
diff --git a/lisp/graveyard.el b/lisp/graveyard.el new file mode 100644 index 0000000..89a776d --- /dev/null +++ b/lisp/graveyard.el | |||
@@ -0,0 +1,50 @@ | |||
1 | ;;; graveyard.el --- stuff i'm not currently using right now | ||
2 | |||
3 | ;;; Commentary: | ||
4 | |||
5 | ;; I spent a long time configuring these packages! And they're misbehaving, | ||
6 | ;; boo. So into the graveyard they go. | ||
7 | |||
8 | ;;; Code: | ||
9 | |||
10 | (use-package emms | ||
11 | :ensure t | ||
12 | :init | ||
13 | (require 'emms-setup) | ||
14 | (autoload #'+emms-streams "+emms" nil t) | ||
15 | (defkeys t "C-c p s" #'+emms-streams) | ||
16 | (defhook (emms-playlist-mode-hook | ||
17 | emms-browser-mode-hook | ||
18 | emms-show-all-mode-hook) | ||
19 | #'hl-line-mode | ||
20 | #'show-paren-mode) | ||
21 | :config | ||
22 | (require '+emms) | ||
23 | (emms-all) | ||
24 | (emms-default-players) | ||
25 | (emms-browser-make-filter "all" #'ignore) | ||
26 | (emms-browser-make-filter "recent" | ||
27 | (lambda (track) | ||
28 | (< 30 (time-to-number-of-days | ||
29 | (time-subtract (current-time) | ||
30 | (emms-info-track-file-mtime | ||
31 | track)))))) | ||
32 | (emms-browser-set-filter (assoc "all" emms-browser-filters)) | ||
33 | (emms-history-load) | ||
34 | (emms-playing-time-mode -1) | ||
35 | :bind | ||
36 | (("C-c p p" . emms-pause) | ||
37 | ("C-c p b" . emms-browser) | ||
38 | ("C-c p l" . emms-playlist-mode-go)) | ||
39 | :custom | ||
40 | (emms-source-file-default-directory (expand-file-name "~/var/music/")) | ||
41 | (emms-source-playlist-default-format 'm3u) | ||
42 | (emms-playlist-mode-center-when-go t) | ||
43 | (emms-playlist-default-major-mode 'emms-playlist-mode) | ||
44 | (emms-player-mpv-update-metadata t) | ||
45 | (emms-browser-covers #'emms-browser-cache-thumbnail-async) | ||
46 | (emms-browser-thumbnail-small-size 64) | ||
47 | (emms-browser-thumbnail-medium-size 128) | ||
48 | (emms-streams-file (expand-file-name "streams.emms" | ||
49 | emms-source-file-default-directory)) | ||
50 | (emms-mode-line-mode-line-function nil)) | ||
diff --git a/lisp/init-org.el b/lisp/init-org.el new file mode 100644 index 0000000..d2d5e77 --- /dev/null +++ b/lisp/init-org.el | |||
@@ -0,0 +1,144 @@ | |||
1 | ;;; init-org.el -*- lexical-binding: t; -*- | ||
2 | |||
3 | (use-package org | ||
4 | :defer t | ||
5 | :custom | ||
6 | (org-adapt-indentation nil) | ||
7 | (org-auto-align-tags t) | ||
8 | (org-archive-mark-done t) | ||
9 | (org-fold-catch-invisible-edits 'show-and-error) | ||
10 | (org-clock-clocked-in-display 'mode-line) | ||
11 | (org-clock-string-limit 7) ; just the clock bit | ||
12 | |||
13 | (org-clock-persist nil) | ||
14 | (org-confirm-babel-evaluate nil) | ||
15 | (org-cycle-separator-lines 0) | ||
16 | (org-directory (sync/ "org/" t)) | ||
17 | (org-fontify-done-headline t) | ||
18 | (org-fontify-quote-and-verse-blocks t) | ||
19 | (org-fontify-whole-heading-line t) | ||
20 | (org-hide-emphasis-markers t) | ||
21 | (org-html-coding-system 'utf-8-unix) | ||
22 | (org-image-actual-width (list (* (window-font-width) | ||
23 | (- fill-column 8)))) | ||
24 | (org-imenu-depth 3) | ||
25 | (org-indent-indentation-per-level 0) | ||
26 | (org-indent-mode-turns-on-hiding-stars nil) | ||
27 | (org-insert-heading-respect-content t) | ||
28 | (org-list-demote-modify-bullet '(("-" . "+") | ||
29 | ("+" . "-"))) | ||
30 | (org-log-done 'time) | ||
31 | (org-log-into-drawer t) | ||
32 | (org-num-skip-commented t) | ||
33 | (org-num-skip-unnumbered t) | ||
34 | (org-num-skip-footnotes t) | ||
35 | (org-outline-path-complete-in-steps nil) | ||
36 | (org-pretty-entities t) | ||
37 | (org-pretty-entities-include-sub-superscripts nil) | ||
38 | (org-refile-targets '((nil . (:maxlevel . 2)) | ||
39 | (org-agenda-files . (:maxlevel . 1)))) | ||
40 | (org-refile-use-outline-path 'file) | ||
41 | (org-special-ctrl-a/e t) | ||
42 | (org-special-ctrl-k t) | ||
43 | (org-src-fontify-natively t) | ||
44 | (org-src-tab-acts-natively t) | ||
45 | (org-src-window-setup 'current-window) | ||
46 | (org-startup-truncated nil) | ||
47 | (org-startup-with-inline-images t) | ||
48 | (org-tags-column 0) | ||
49 | (org-todo-keywords | ||
50 | '((sequence "TODO(t)" "WAIT(w@/!)" "ONGOING(o@)" | ||
51 | "|" "DONE(d!)" "ASSIGNED(a@/!)") | ||
52 | (sequence "|" "CANCELED(k@)") | ||
53 | (sequence "MEETING(m)"))) | ||
54 | (org-use-speed-commands t) | ||
55 | :config | ||
56 | (require '+org) | ||
57 | (defkeys org-mode-map | ||
58 | "C-M-k" #'kill-paragraph | ||
59 | "C-M-t" #'transpose-paragraphs | ||
60 | "RET" #'+org-return-dwim | ||
61 | "S-<return>" #'+org-table-copy-down|+org-return-dwim | ||
62 | "C-c C-o" #'+org-open-at-point-dwim) | ||
63 | (setc org-ellipsis | ||
64 | (or (bound-and-true-p truncate-string-ellipsis) "…") | ||
65 | org-emphasis-alist | ||
66 | '(("*" org-bold) | ||
67 | ("/" org-italic) | ||
68 | ("_" org-underline) | ||
69 | ("=" org-verbatim) | ||
70 | ("~" org-code) | ||
71 | ("+" org-strikethrough))) | ||
72 | (defhook org-mode-hook | ||
73 | #'variable-pitch-mode | ||
74 | #'visual-fill-column-mode | ||
75 | #'turn-off-auto-fill | ||
76 | #'org-indent-mode | ||
77 | #'prettify-symbols-mode | ||
78 | #'abbrev-mode | ||
79 | (defhook ((before-save-hook nil :local)) | ||
80 | :name before-save@org-mode | ||
81 | (+org-hide-drawers-except-point) | ||
82 | (org-align-tags 'all)))) | ||
83 | |||
84 | (use-package org-agenda | ||
85 | :custom | ||
86 | (org-agenda-skip-deadline-if-done t) | ||
87 | (org-agenda-skip-scheduled-if-done t) | ||
88 | (org-agenda-span 10) | ||
89 | (org-agenda-block-separator ?─) | ||
90 | (org-agenda-time-grid | ||
91 | '((daily today require-timed) | ||
92 | (800 1000 1200 1400 1600 1800 2000) | ||
93 | " ┄┄┄┄┄ " "┄┄┄┄┄┄┄┄┄┄┄┄┄┄┄")) | ||
94 | (org-agenda-current-time-string | ||
95 | "← now ─────────────────────────────────────────────────") | ||
96 | (org-agenda-include-diary nil) ; I use the org-diary features | ||
97 | |||
98 | (org-agenda-todo-ignore-deadlines 'near) | ||
99 | (org-agenda-todo-ignore-scheduled 'future) | ||
100 | (org-agenda-include-deadlines t) | ||
101 | (org-deadline-warning-days 0) | ||
102 | (org-agenda-show-future-repeats 'next) | ||
103 | (org-agenda-window-setup 'current-window) | ||
104 | (org-agenda-file-skip-regexp "sync-conflict") | ||
105 | :bind (("C-c a" . org-agenda)) | ||
106 | :config | ||
107 | (require '+org) | ||
108 | (advice-add 'org-agenda-files :filter-return #'org-agenda-files@skip-regexp) | ||
109 | (defhook org-agenda-mode-hook | ||
110 | (setq-local truncate-lines t) | ||
111 | #'hl-line-mode) | ||
112 | (defhook org-agenda-after-show-hook | ||
113 | #'org-narrow-to-subtree)) | ||
114 | |||
115 | (use-package org-capture | ||
116 | :bind | ||
117 | (("C-c c" . org-capture))) | ||
118 | |||
119 | (use-package ol ; org-link | ||
120 | :after org | ||
121 | :config | ||
122 | (require '+org) | ||
123 | (+org-link-define-type sms (number _)) | ||
124 | (+org-link-define-type tel (number _))) | ||
125 | |||
126 | (use-package ox ; org-export | ||
127 | :defer t | ||
128 | :custom | ||
129 | (org-export-coding-system 'utf-8-unix) | ||
130 | (org-export-headline-levels 8) | ||
131 | (org-export-with-drawers nil) | ||
132 | (org-export-with-section-numbers nil) | ||
133 | (org-export-with-smart-quotes t) | ||
134 | (org-export-with-sub-superscripts t) | ||
135 | (org-export-with-toc nil) | ||
136 | :config | ||
137 | (require 'ox-md)) | ||
138 | |||
139 | (use-package org-word-count | ||
140 | :load-path "~/src/emacs/org-word-count/" | ||
141 | :hook org-mode-hook) | ||
142 | |||
143 | (provide 'init-org) | ||
144 | ;;; init-org.el ends here | ||
diff --git a/lisp/org-word-count.el b/lisp/org-word-count.el deleted file mode 100644 index d6d2598..0000000 --- a/lisp/org-word-count.el +++ /dev/null | |||
@@ -1,297 +0,0 @@ | |||
1 | ;;; org-word-count.el --- org-word-count in the modeline -*- lexical-binding: t; -*- | ||
2 | |||
3 | ;;; Commentary: | ||
4 | |||
5 | ;;; Code: | ||
6 | |||
7 | (require 'org) | ||
8 | (require 'cl-lib) | ||
9 | |||
10 | (defgroup org-word-count nil | ||
11 | "Extra fast word-counting in `org-mode'." | ||
12 | :group 'org) | ||
13 | |||
14 | (defvar-local org-word-count-word-count nil | ||
15 | "Running total of words in this buffer.") | ||
16 | |||
17 | (defvar-local org-word-count-string nil | ||
18 | "String for the modeline.") | ||
19 | |||
20 | (defcustom org-word-count-format "%sw " | ||
21 | "Format for org word count in modeline." | ||
22 | :type 'string) | ||
23 | |||
24 | (defcustom org-word-count-huge-string "huge" | ||
25 | "String to display with a huge buffer." | ||
26 | :type 'string) | ||
27 | |||
28 | (defcustom org-word-count-update-after-funcs '(org-narrow-to-subtree | ||
29 | org-narrow-to-block | ||
30 | org-narrow-to-element | ||
31 | org-capture-narrow) | ||
32 | "Functions after which to update the word count." | ||
33 | :type '(repeat function)) | ||
34 | |||
35 | (defcustom org-word-count-deletion-idle-timer 0.25 | ||
36 | "Length of time, in seconds, to wait before updating word-count." | ||
37 | :type 'number) | ||
38 | |||
39 | (defcustom org-word-count-huge-change 5000 | ||
40 | "Number of characters that constitute a \"huge\" insertion." | ||
41 | :type 'number) | ||
42 | |||
43 | (defcustom org-word-count-huge-buffer 10000 | ||
44 | "Number of words past which we're not going to try to count." | ||
45 | :type 'number) | ||
46 | |||
47 | (defvar org-word-count-correction -5 | ||
48 | "Number to add to `org-word-count-word-count', for some reason? | ||
49 | `org-word-count-word-count' seems to consistently be off by 5. Thus | ||
50 | this correction. (At some point I should correct the underlying | ||
51 | code... probably).") | ||
52 | |||
53 | (defvar-local org-word-count-update-timer nil) | ||
54 | |||
55 | ;;; Variables from org-wc | ||
56 | |||
57 | (defun org-word-count-list-of-strings-p (arg) | ||
58 | (cl-every #'stringp arg)) | ||
59 | |||
60 | (defun org-word-count--downcase-list-of-strings-set-default (var val) | ||
61 | (set-default var (mapcar #'downcase val))) | ||
62 | |||
63 | (defcustom org-word-count-ignored-tags '("nowc" "noexport" "ARCHIVE") | ||
64 | "List of tags for which subtrees will be ignored in word counts" | ||
65 | :type '(repeat string) | ||
66 | :safe #'org-word-count-list-of-strings-p) | ||
67 | |||
68 | (defcustom org-word-count-ignore-commented-trees t | ||
69 | "Ignore trees with COMMENT-prefix if non-nil." | ||
70 | :type 'boolean | ||
71 | :safe #'booleanp) | ||
72 | |||
73 | (defcustom org-word-count-default-link-count 'description-or-path | ||
74 | "Default way of counting words in links. | ||
75 | This is applied to any link type not specified in any of | ||
76 | ‘org-word-count-ignored-link-types’,‘org-word-count-one-word-link-types’, or | ||
77 | ‘org-word-count-only-description-link-types’ " | ||
78 | :type '(choice | ||
79 | (const :tag "Count words in description or else path part of links" description-or-path) | ||
80 | (const :tag "Count words only in description part of links" description) | ||
81 | (const :tag "Count links as 0 words" ignore) | ||
82 | (const :tag "Count links as 1 word" oneword) | ||
83 | (const :tag "Count words only in path part of links" path)) | ||
84 | :safe 'symbolp) | ||
85 | |||
86 | (defcustom org-word-count-ignored-link-types nil | ||
87 | "Link types which won't be counted as a word" | ||
88 | :type '(repeat string) | ||
89 | :safe #'org-word-count-list-of-strings-p) | ||
90 | |||
91 | (defcustom org-word-count-one-word-link-types '("zotero") | ||
92 | "Link types which will be counted as one word" | ||
93 | :type '(repeat string) | ||
94 | :safe #'org-word-count-list-of-strings-p) | ||
95 | |||
96 | (defcustom org-word-count-description-or-path-link-types '() | ||
97 | "Link types for which the description or the path should be counted" | ||
98 | :type '(repeat string) | ||
99 | :safe #'org-word-count-list-of-strings-p) | ||
100 | |||
101 | (defcustom org-word-count-only-description-link-types '("note") | ||
102 | "Link types for which only the description should be counted" | ||
103 | :type '(repeat string) | ||
104 | :safe #'org-word-count-list-of-strings-p) | ||
105 | |||
106 | (defcustom org-word-count-only-path-link-types '() | ||
107 | "Link types for which only the path should be counted" | ||
108 | :type '(repeat string) | ||
109 | :safe #'org-word-count-list-of-strings-p) | ||
110 | |||
111 | (defcustom org-word-count-blocks-to-count '("quote" "verse") | ||
112 | "List of blocks which should be included in word count. | ||
113 | |||
114 | Use lower case block names" | ||
115 | :type '(repeat string) | ||
116 | :safe #'org-word-count-list-of-strings-p | ||
117 | :set #'org-word-count--downcase-list-of-strings-set-default) | ||
118 | |||
119 | (defun org-word-count-delayed-update (&rest _) | ||
120 | (if org-word-count-update-timer | ||
121 | (setq org-word-count-update-timer nil) | ||
122 | (setq org-word-count-update-timer | ||
123 | (run-with-idle-timer org-word-count-deletion-idle-timer nil | ||
124 | #'org-word-count-update)))) | ||
125 | |||
126 | (defun org-word-count-force-update () | ||
127 | (interactive) | ||
128 | (message "Counting words...") | ||
129 | (when (timerp org-word-count-update-timer) | ||
130 | (cancel-timer org-word-count-update-timer)) | ||
131 | (org-word-count-update) | ||
132 | (message "Counting words...done")) | ||
133 | |||
134 | (defun org-word-count-update (&rest _) ; Needs variadic parameters, since it's advice | ||
135 | (dlet ((org-word-count-counting t)) | ||
136 | (org-word-count-buffer) | ||
137 | (org-word-count-modeline) | ||
138 | (setq org-word-count-update-timer nil))) | ||
139 | |||
140 | (defun org-word-count-changed (start end length) | ||
141 | (org-word-count-delayed-update)) | ||
142 | |||
143 | (defun org-word-count-buffer () | ||
144 | "Count the words in the buffer." | ||
145 | (when (and (derived-mode-p 'org-mode) | ||
146 | (not (eq org-word-count-word-count 'huge))) | ||
147 | (setq org-word-count-word-count | ||
148 | (cond | ||
149 | ((> (count-words (point-min) (point-max)) | ||
150 | org-word-count-huge-buffer) | ||
151 | 'huge) | ||
152 | (t (org-word-count-aux (point-min) (point-max))))))) | ||
153 | |||
154 | ;;; From org-wc.el: | ||
155 | ;; https://github.com/tesujimath/org-wc/ | ||
156 | (defun org-word-count-aux (beg end) | ||
157 | "Return the number of words between BEG and END." | ||
158 | (let ((wc 0) | ||
159 | subtreecount | ||
160 | (latex-macro-regexp "\\\\[A-Za-z]+\\(\\[[^]]*\\]\\|\\){\\([^}]*\\)}")) | ||
161 | (save-excursion | ||
162 | (goto-char beg) | ||
163 | ;; Handle the case where we start in a drawer | ||
164 | (when (org-at-drawer-p) | ||
165 | (org-end-of-meta-data t)) | ||
166 | (while (< (point) end) | ||
167 | (cond | ||
168 | ;; Handle headlines and subtrees | ||
169 | ((org-at-heading-p) | ||
170 | (cond | ||
171 | ;; Ignore commented and org-wc-ignored-tags trees | ||
172 | ((or (and org-word-count-ignore-commented-trees (org-in-commented-heading-p)) | ||
173 | (cl-intersection org-word-count-ignored-tags (org-get-tags) :test #'string=)) | ||
174 | (org-end-of-subtree t t)) | ||
175 | ;; Re-use count for subtrees already counted | ||
176 | ((setq subtreecount (get-text-property (point) :org-wc)) | ||
177 | (cl-incf wc subtreecount) | ||
178 | (org-end-of-subtree t t)) | ||
179 | ;; Skip counting words in headline | ||
180 | (t (org-word-count--goto-char (point-at-eol) end)))) | ||
181 | ;; Ignore most blocks. | ||
182 | ((when (save-excursion | ||
183 | (beginning-of-line 1) | ||
184 | (looking-at org-block-regexp)) | ||
185 | (if (member (downcase (match-string 1)) org-word-count-blocks-to-count) | ||
186 | (progn ;; go inside block and subtract count of end line | ||
187 | (org-word-count--goto-char (match-beginning 4) end) | ||
188 | (cl-decf wc)) | ||
189 | (org-word-count--goto-char (match-end 0) end)))) | ||
190 | ;; Ignore comments. | ||
191 | ((org-at-comment-p) | ||
192 | (org-word-count--goto-char (point-at-eol) end)) | ||
193 | ;; Ignore drawers. | ||
194 | ((org-at-drawer-p) | ||
195 | (org-end-of-meta-data t)) | ||
196 | ;; Ignore all other #+ lines | ||
197 | ((looking-at "#+") | ||
198 | (org-word-count--goto-char (point-at-eol) end)) | ||
199 | ;; Handle links | ||
200 | ((save-excursion | ||
201 | (when (< (1+ (point-min)) (point)) (backward-char 2)) | ||
202 | (looking-at org-link-bracket-re)) | ||
203 | (let* ((type (car (save-match-data (split-string (match-string 1) ":")))) | ||
204 | (pathstart (+ 1 (length type) (match-beginning 1)))) | ||
205 | (cl-case (cond ((member type org-word-count-ignored-link-types) 'ignore) | ||
206 | ((member type org-word-count-one-word-link-types) 'oneword) | ||
207 | ((member type org-word-count-only-description-link-types) | ||
208 | 'description) | ||
209 | ((member type org-word-count-only-path-link-types) 'path) | ||
210 | ((member type org-word-count-description-or-path-link-types) | ||
211 | 'description-or-path) | ||
212 | (t org-word-count-default-link-count)) | ||
213 | (ignore (org-word-count--goto-char (match-end 0) end)) | ||
214 | (oneword (org-word-count--goto-char (match-end 0) end) | ||
215 | (cl-incf wc)) | ||
216 | (description (if (match-beginning 2) | ||
217 | (goto-char (match-beginning 2)) | ||
218 | (org-word-count--goto-char | ||
219 | (match-end 0) end))) | ||
220 | (path (cl-incf wc (count-words-region pathstart | ||
221 | (match-end 1))) | ||
222 | (org-word-count--goto-char (match-end 0) end)) | ||
223 | (description-or-path | ||
224 | (if (match-beginning 2) | ||
225 | (goto-char (match-beginning 2)) | ||
226 | (cl-incf wc (count-words-region pathstart | ||
227 | (match-end 1))) | ||
228 | (org-word-count--goto-char (match-end 0) end))) | ||
229 | (t (user-error "Error in org-word-count link configuration"))))) | ||
230 | ;; Count latex macros as 1 word, ignoring their arguments. | ||
231 | ((save-excursion | ||
232 | (when (< (point-min) (point)) (backward-char)) | ||
233 | (looking-at latex-macro-regexp)) | ||
234 | (org-word-count--goto-char (match-end 0) end) | ||
235 | (cl-incf wc)) | ||
236 | (t | ||
237 | (and (re-search-forward "\\w+\\W*" end 'skip) | ||
238 | (cl-incf wc)))))) | ||
239 | wc)) | ||
240 | |||
241 | (defun org-word-count--goto-char (char end) | ||
242 | "Moves point to CHAR and from there passes 0+ non-word characters. | ||
243 | Searchers to end as a maximum. | ||
244 | |||
245 | This ensures that we are in an expected state (at the first word | ||
246 | character after some non-word characters) after moving beyond | ||
247 | headlines, links etc." | ||
248 | (goto-char char) | ||
249 | (re-search-forward "\\W*" end 'skip)) | ||
250 | |||
251 | (defvar org-word-count-counting nil | ||
252 | "Are we currently counting?") | ||
253 | |||
254 | (defun org-word-count-recount-widen (&rest _) | ||
255 | (when (and (not org-word-count-counting)) | ||
256 | (org-word-count-update))) | ||
257 | |||
258 | (defun org-word-count-modeline () | ||
259 | (setq org-word-count-string | ||
260 | (cond | ||
261 | ((eq org-word-count-word-count 'huge) | ||
262 | org-word-count-huge-string) | ||
263 | (org-word-count-word-count | ||
264 | (format org-word-count-format | ||
265 | (max 0 (+ org-word-count-word-count | ||
266 | org-word-count-correction)))))) | ||
267 | (force-mode-line-update)) | ||
268 | |||
269 | (define-minor-mode org-word-count-mode | ||
270 | "Count words in `org-mode' buffers in the mode-line." | ||
271 | :lighter "" | ||
272 | :keymap (let ((map (make-sparse-keymap))) | ||
273 | (define-key map (kbd "C-c C-.") #'org-word-count-force-update) | ||
274 | map) | ||
275 | (cond (org-word-count-mode | ||
276 | (org-word-count-buffer) | ||
277 | (add-hook 'after-change-functions | ||
278 | #'org-word-count-delayed-update nil t) | ||
279 | (unless (member '(org-word-count-mode org-word-count-string) | ||
280 | mode-line-misc-info) | ||
281 | (add-to-list 'mode-line-misc-info | ||
282 | '(org-word-count-mode org-word-count-string) | ||
283 | nil | ||
284 | #'equal)) | ||
285 | (dolist (fn org-word-count-update-after-funcs) | ||
286 | (advice-add fn :after #'org-word-count-update))) | ||
287 | (:else | ||
288 | (remove-hook 'after-change-functions | ||
289 | #'org-word-count-delayed-update t) | ||
290 | (setf mode-line-misc-info | ||
291 | (delete '(org-word-count-mode org-word-count-string) | ||
292 | mode-line-misc-info)) | ||
293 | (dolist (fn org-word-count-update-after-funcs) | ||
294 | (advice-remove fn #'org-word-count-update))))) | ||
295 | |||
296 | (provide 'org-word-count) | ||
297 | ;;; org-word-count.el ends here | ||
diff --git a/lisp/pita.el b/lisp/pita.el deleted file mode 100644 index ed67c92..0000000 --- a/lisp/pita.el +++ /dev/null | |||
@@ -1,69 +0,0 @@ | |||
1 | ;;; pita.el --- wrappers making emacs less of a PITA -*- lexical-binding: t -*- | ||
2 | ;; 🥙 | ||
3 | |||
4 | ;;; utils | ||
5 | |||
6 | (defun walk-tree-replace (tree find replace) | ||
7 | (let ((r nil)) | ||
8 | (dolist (form tree) | ||
9 | (push (cond ((eq find form) replace) | ||
10 | ((listp form) | ||
11 | (walk-tree-replace form find replace)) | ||
12 | (t form)) | ||
13 | r)) | ||
14 | (reverse r))) | ||
15 | |||
16 | ;;; crux advices | ||
17 | ;; these should all go :before the function they're advising. | ||
18 | |||
19 | (defun with-region-or-buffer (&rest _) | ||
20 | (interactive (if mark-active | ||
21 | (list (region-beginning) (region-end)) | ||
22 | (list (point-min) (point-max))))) | ||
23 | |||
24 | (defun with-region-or-line (&rest _) | ||
25 | (interactive (if mark-active | ||
26 | (list (region-beginning) (region-end)) | ||
27 | (list (line-beginning-position) (line-end-position))))) | ||
28 | |||
29 | (defun with-region-or-to-eol (&rest _) | ||
30 | (interactive (if mark-active | ||
31 | (list (region-beginning) (region-end)) | ||
32 | (list (point) (line-end-position))))) | ||
33 | |||
34 | ;;; wrappers | ||
35 | |||
36 | (defmacro with-message (msg &rest body) | ||
37 | (declare (indent 1)) | ||
38 | (when (listp msg) | ||
39 | (setq msg (apply #'format (car msg) (cdr msg)))) | ||
40 | (when (string-match "[[:alnum:]]\\'" msg) | ||
41 | (setq msg (concat msg "..."))) | ||
42 | (let ((m (gensym)) | ||
43 | (r (gensym))) | ||
44 | `(let ((,m ,msg) | ||
45 | (,r nil)) | ||
46 | (condition-case e | ||
47 | (setq r (progn (message ,m) ,@body)) | ||
48 | (:success (message "%s done" ,m) r) | ||
49 | (t (signal (car e) (cdr e))))))) | ||
50 | |||
51 | (defmacro with-pr (msg &rest body) | ||
52 | (declare (indent 1)) | ||
53 | (when (listp msg) | ||
54 | (setq msg (apply #'format (car msg) (cdr msg)))) | ||
55 | (when (string-match "[[:alnum:]]\\'" msg) | ||
56 | (setq msg (concat msg "..."))) | ||
57 | (let ((pr (gensym)) | ||
58 | (m (gensym))) | ||
59 | `(let* ((,m ,msg) | ||
60 | (,pr (unless (minibufferp) | ||
61 | (make-progress-reporter ,m)))) | ||
62 | ,@(or (and pr (walk-tree-replace body '@ `(progress-reporter-update ,pr))) | ||
63 | body) | ||
64 | (and ,pr (progress-reporter-done ,pr))))) | ||
65 | |||
66 | ;;; wrapper advice | ||
67 | |||
68 | (provide 'pita) | ||
69 | ;;; pita.el ends here | ||
diff --git a/lisp/private.el b/lisp/private.el deleted file mode 100644 index 4f6115e..0000000 --- a/lisp/private.el +++ /dev/null | |||
@@ -1,23 +0,0 @@ | |||
1 | ;;; private.el -*- lexical-binding: t; -*- | ||
2 | |||
3 | ;;; Commentary: | ||
4 | |||
5 | ;;; Code: | ||
6 | |||
7 | (require 'acdw) | ||
8 | |||
9 | (defgroup private nil | ||
10 | "Private things are private. Shhhhh....") | ||
11 | |||
12 | ;; Private directory | ||
13 | |||
14 | (+define-dir private/ (sync/ "emacs/private") | ||
15 | "Private secretive secrets inside.") | ||
16 | (add-to-list 'load-path private/) | ||
17 | |||
18 | ;; Load random private stuff | ||
19 | |||
20 | (require '_acdw) | ||
21 | |||
22 | (provide 'private) | ||
23 | ;;; private.el ends here | ||
diff --git a/lisp/scule.el b/lisp/scule.el deleted file mode 100644 index 3ed58bb..0000000 --- a/lisp/scule.el +++ /dev/null | |||
@@ -1,61 +0,0 @@ | |||
1 | ;;; scule.el --- -scule twiddling -*- lexical-binding: t; -*- | ||
2 | |||
3 | ;; Copyright (C) 2022 Case Duckworth | ||
4 | |||
5 | ;; Author: Case Duckworth <case@bob> | ||
6 | ;; Keywords: convenience | ||
7 | |||
8 | ;; This program is free software; you can redistribute it and/or modify | ||
9 | ;; it under the terms of the GNU General Public License as published by | ||
10 | ;; the Free Software Foundation, either version 3 of the License, or | ||
11 | ;; (at your option) any later version. | ||
12 | |||
13 | ;; This program is distributed in the hope that it will be useful, | ||
14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
16 | ;; GNU General Public License for more details. | ||
17 | |||
18 | ;; You should have received a copy of the GNU General Public License | ||
19 | ;; along with this program. If not, see <https://www.gnu.org/licenses/>. | ||
20 | |||
21 | ;;; Commentary: | ||
22 | |||
23 | ;; DWIM functions for twiddling "scule", or text case (a fancy word for "upper | ||
24 | ;; case" is "magiscule", for example, and "lower case" is "miniscule"). | ||
25 | |||
26 | ;;; Code: | ||
27 | |||
28 | (require 'thingatpt) | ||
29 | |||
30 | ;;; Utility macro | ||
31 | ;;;###autoload | ||
32 | (defmacro defscule (name &optional region-fn word-fn) | ||
33 | (let ((fn-name (intern (format "scule-%s" name))) | ||
34 | (region-fn (or region-fn (intern (format "%s-region" name)))) | ||
35 | (word-fn (or word-fn (intern (format "%s-word" name))))) | ||
36 | `(defun ,fn-name (arg) | ||
37 | ,(concat (capitalize (symbol-name name)) " words in the region if active, or word at point.\n" | ||
38 | "If the region is active, call `" (symbol-name region-fn) "'.\n" | ||
39 | "Otherwise, it calls `" (symbol-name word-fn) "' on the word at point and\n" | ||
40 | "the following ARG - 1 words.") | ||
41 | (interactive "*p") | ||
42 | (if (use-region-p) | ||
43 | (,region-fn (region-beginning) (region-end) (region-noncontiguous-p)) | ||
44 | (let ((word-bound (save-excursion | ||
45 | (skip-chars-forward "^[:word:]") | ||
46 | (bounds-of-thing-at-point 'word)))) | ||
47 | (when (and (car word-bound) (cdr word-bound)) | ||
48 | (,region-fn (car word-bound) (cdr word-bound)) | ||
49 | (goto-char (cdr word-bound)) | ||
50 | (,word-fn (1- arg)))))))) | ||
51 | |||
52 | ;;;###autoload | ||
53 | (progn (defscule upcase) | ||
54 | (autoload 'scule-upcase "scule" nil t) | ||
55 | (defscule downcase) | ||
56 | (autoload 'scule-downcase "scule" nil t) | ||
57 | (defscule capitalize) | ||
58 | (autoload 'scule-capitalize "scule" nil t)) | ||
59 | |||
60 | (provide 'scule) | ||
61 | ;;; scule.el ends here | ||
diff --git a/lisp/upload-junk.el b/lisp/upload-junk.el new file mode 100644 index 0000000..5a9da84 --- /dev/null +++ b/lisp/upload-junk.el | |||
@@ -0,0 +1,47 @@ | |||
1 | ;;; upload-junk.el --- Upload junk -*- lexical-binding: t; -*- | ||
2 | |||
3 | ;;; Code: | ||
4 | |||
5 | (require 'tramp) | ||
6 | |||
7 | (defvar upload-junk-ssh-host "hetzner" | ||
8 | "SSH host to upload to.") | ||
9 | |||
10 | (defvar upload-junk-ssh-root "/junk" | ||
11 | "SSH root folder to upload to.") | ||
12 | |||
13 | (defvar upload-junk-web-host "https://junk.acdw.net" | ||
14 | "Web host to link uploads to.") | ||
15 | |||
16 | (defun upload-junk-file-name (&optional file) | ||
17 | "Return the uploaded filename for FILE." | ||
18 | (let ((file (or file "_.txt"))) | ||
19 | (format "tmp_%s_%x%x.%s" | ||
20 | (file-name-nondirectory (file-name-sans-extension file)) | ||
21 | (time-convert (current-time) 'integer) | ||
22 | (random (* 8 8 8 8)) | ||
23 | (or (file-name-extension file) "txt")))) | ||
24 | |||
25 | (defun upload-junk-region (start end) | ||
26 | "Upload region from START to END to my server." | ||
27 | (interactive "r") | ||
28 | (let* ((s (buffer-substring-no-properties start end)) | ||
29 | (f (upload-junk-file-name (buffer-file-name))) | ||
30 | (w (format "%s/%s" upload-junk-web-host f))) | ||
31 | (with-temp-buffer | ||
32 | (insert s) | ||
33 | (write-file (format "/sshx:%s:%s/%s" | ||
34 | upload-junk-ssh-host | ||
35 | upload-junk-ssh-root | ||
36 | f))) | ||
37 | (kill-new w) | ||
38 | w)) | ||
39 | |||
40 | (defun upload-junk-region-or-buffer () | ||
41 | (interactive) | ||
42 | (if (region-active-p) | ||
43 | (upload-junk-region (region-beginning) (region-end)) | ||
44 | (upload-junk-region (point-min) (point-max)))) | ||
45 | |||
46 | (provide 'upload-junk) | ||
47 | ;;; upload-junk.el ends here | ||
diff --git a/lisp/yoke.el b/lisp/yoke.el index 8ca94fd..ec84f56 100644 --- a/lisp/yoke.el +++ b/lisp/yoke.el | |||
@@ -1,271 +1,360 @@ | |||
1 | ;;; yoke.el --- make your editor work for YOU -*- lexical-binding: t; -*- | 1 | ;;; yoke.el --- Yoke configuration into your config -*- lexical-binding: t; -*- |
2 | ;; Copyright (C) 2022 C. Duckworth <acdw@acdw.net> | 2 | |
3 | ;; Copyright (C) 2022 Case Duckworth | ||
4 | |||
5 | ;; Author: Case Duckworth <case@bob> | ||
6 | ;; Keywords: convenience | ||
7 | ;; Package-Version: 0.61803398875 | ||
8 | ;; Homepage: https://junk.acdw.net/yoke.el | ||
9 | ;; Package-Requires: ((emacs "28.1")) | ||
10 | |||
11 | ;; This program is free software; you can redistribute it and/or modify | ||
12 | ;; it under the terms of the GNU General Public License as published by | ||
13 | ;; the Free Software Foundation, either version 3 of the License, or | ||
14 | ;; (at your option) any later version. | ||
15 | |||
16 | ;; This program is distributed in the hope that it will be useful, | ||
17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
19 | ;; GNU General Public License for more details. | ||
20 | |||
21 | ;; You should have received a copy of the GNU General Public License | ||
22 | ;; along with this program. If not, see <https://www.gnu.org/licenses/>. | ||
3 | 23 | ||
4 | ;;; Commentary: | 24 | ;;; Commentary: |
5 | 25 | ||
6 | ;; What's the most basic functionality of a package manager? In my view, all a | 26 | ;; THIS IS A WORK IN PROGRESS. DON'T USE IT. |
7 | ;; package manager should do is fetch packages from wherever they are, and | ||
8 | ;; provide the system with a method of accessing those packages' functionality. | ||
9 | ;; In Emacs, this means downloading packages from the Internet and adding their | ||
10 | ;; directories to `load-path'. That's what `yoke' tries to do. | ||
11 | ;; | ||
12 | ;; In fact, that's /all/ `yoke' tries to do, on the package front. It doesn't | ||
13 | ;; automatically fetch dependencies. It doesnt' do much else of anything | ||
14 | ;; --- hell, it doesn't have to generate autoloads or build the dang source | ||
15 | ;; files if you don't want it to. /I/ have it do those things because I like a | ||
16 | ;; few creature comforts, but you can turn 'em off. | ||
17 | ;; | ||
18 | ;; Instead of focusing too much on installing packages, `yoke' works harder to | ||
19 | ;; group---to "yoke together," if you will---related configurations together, à | ||
20 | ;; la `use-package' or `setup'. I used both of those packages before and found | ||
21 | ;; each somewhat lacking, and what I really wanted was a fancy `progn' that I | ||
22 | ;; could put whatever I want inside. So that's basically what `yoke' is. It's | ||
23 | ;; a configuration macro that automatically fetches packages from their repos | ||
24 | ;; and tells Emacs where they are, then executes its body in a `cl-block' for | ||
25 | ;; ... reasons. That's it. | ||
26 | 27 | ||
27 | ;;; Code: | 28 | ;;; Code: |
28 | 29 | ||
29 | (require 'cl-lib) | 30 | (require 'cl-lib) |
31 | (require 'package-vc) | ||
30 | 32 | ||
31 | ;;; Customization options | 33 | ;;; User options |
32 | 34 | ||
33 | (defgroup yoke nil | 35 | (defgroup yoke nil |
34 | "Customizations for `yoke'." | 36 | "Customizations for `yoke'." |
35 | :group 'applications | 37 | :group 'convenience |
36 | :prefix "yoke-") | 38 | :prefix "yoke-") |
37 | 39 | ||
38 | (defcustom yoke-dir (locate-user-emacs-file "yoke") | 40 | (defcustom yoke-directory package-user-dir |
39 | "Where to put yoked packages." | 41 | "Where to put yoked packages." |
40 | :type 'file) | 42 | :type 'file) |
41 | 43 | ||
42 | (defcustom yoke-get-default-fn #'yoke-get-git | 44 | (defcustom yoke-cache-directory (locate-user-emacs-file "yoke-cache" |
43 | "Default function to get packages with." | 45 | "~/.yoke-cache") |
44 | :type 'function) | 46 | "Where to put cached yoke files, like downloaded HTTP packages." |
47 | :type 'file) | ||
48 | |||
49 | (defcustom yoke-debug-on-error nil | ||
50 | "Whether to throw up the debugger on a yoke error. | ||
51 | If nil, errors will be inserted in the `yoke-message-buffer'.") | ||
52 | |||
53 | ;;; Variables | ||
54 | |||
55 | (defvar yoke-message-buffer " *yoke*" | ||
56 | "The buffer used for yoke messages.") | ||
57 | |||
58 | (defvar yoke-selected-packages nil | ||
59 | "List of packages managed by `yoke'.") | ||
60 | |||
61 | (defvar yoke-backends '(file http package) | ||
62 | "Backends handled by `yoke'.") | ||
63 | |||
64 | ;;; Main functionality | ||
65 | |||
66 | (defmacro yoke (package &rest body) | ||
67 | "Yoke a package into your Emacs session. | ||
68 | PACKAGE is either a symbol, in which case `yoke' expands to | ||
69 | basically a named `progn' (good for grouping configuration), or a | ||
70 | list of the form (NAME . ARGS), where ARGS can be one of the | ||
71 | following: | ||
72 | |||
73 | - nil: install NAME using `package'. | ||
74 | - a property list describing a package specification. Valid | ||
75 | key/value pairs include | ||
76 | |||
77 | `:backend' (symbol) | ||
78 | A symbol of the yoke backend to use for installing the | ||
79 | package. See `yoke-backends' for allowed backends. | ||
80 | |||
81 | `:url' (string) | ||
82 | The URL of the package's repository or source. | ||
83 | |||
84 | `:lisp-dir' (string) | ||
85 | The repository-relative name of the directory to use for | ||
86 | loading lisp sources. If not given, it defaults to the | ||
87 | repo's root directory. | ||
45 | 88 | ||
46 | (defvar yoke-buffer "*yoke*" | 89 | Other pairs may be valid for a given backend; see that |
47 | "Buffer to use for yoke process output.") | 90 | backend's `yoke-install' function for more details. |
48 | 91 | ||
49 | (defvar yoke-dirs nil | 92 | BODY is executed in a `condition-case' so that errors won't keep |
50 | "List of directories managed by `yoke'.") | 93 | the rest of Emacs from initializing. BODY can also be prepended |
94 | by the following keyword arguments: | ||
51 | 95 | ||
52 | ;;; GET YOKED | 96 | `:after' (FEATURE...) |
53 | 97 | ||
54 | (defmacro yoke (package | 98 | `:require' (FEATURE...) |
55 | &rest body) | ||
56 | "Yoke PACKAGE to work with your Emacs. | ||
57 | Execute BODY afterward. | ||
58 | 99 | ||
59 | \(fn (PACKAGE [REPO REPO-KEYWORDS]) [BODY-KEYWORDS] BODY...)" | 100 | `:depends' (PACKAGE-SPEC...) |
101 | |||
102 | `:build' (ACTION...) | ||
103 | |||
104 | `:unless' (PREDICATE) | ||
105 | |||
106 | `:when' (PREDICATE) | ||
107 | |||
108 | Other keywords are ignored. | ||
109 | |||
110 | \(fn (PACKAGE [SPEC]) [BODY-ARGS] BODY...)" | ||
60 | (declare (indent 1)) | 111 | (declare (indent 1)) |
61 | (let* (;; State | 112 | (let* ((name (or (car-safe package) package)) |
62 | (pkg (cond ((consp package) (car package)) | 113 | (backend (yoke--pget package :backend)) |
63 | (:else package))) | 114 | ;; Body keyword arguments |
64 | (url (cond ((consp package) (cdr package)) | ||
65 | (:else nil))) | ||
66 | (pname (intern (format "yoke:%s" pkg))) | ||
67 | (dirvar '$yoke-dir) | ||
68 | ;; Keyword args --- TODO: Naming could probably be better. | ||
69 | (after (plist-get body :after)) | 115 | (after (plist-get body :after)) |
70 | (depends (plist-get body :depends)) | 116 | (depends (plist-get body :depends)) |
117 | (req (plist-get body :require)) | ||
118 | (buildp (plist-member body :build)) | ||
119 | (build (plist-get body :build)) | ||
71 | (whenp (plist-member body :when)) | 120 | (whenp (plist-member body :when)) |
121 | (when (if whenp (plist-get body :when) t)) | ||
72 | (unlessp (plist-member body :unless)) | 122 | (unlessp (plist-member body :unless)) |
73 | (when (cond (whenp (plist-get body :when)) | 123 | (unless (if unlessp (plist-get body :unless) nil)) |
74 | (:else t))) | ||
75 | (unless (cond (unlessp (plist-get body :unless)) | ||
76 | (:else nil))) | ||
77 | (autoload (cond ((plist-member body :autoload) | ||
78 | (plist-get body :autoload)) | ||
79 | (:else t))) | ||
80 | (pre (plist-get body :pre)) | ||
81 | ;; Body | 124 | ;; Body |
82 | (body (cl-loop for (this next) on body by #'cddr | 125 | (body (let ((b body) r) |
83 | unless (keywordp this) | 126 | (while (consp b) |
84 | append (list this next) into ret | 127 | (if (keywordp (car b)) |
85 | finally return (cond ((eq (car (last ret)) nil) | 128 | (setf b (cdr b)) |
86 | (butlast ret)) | 129 | (setf r (cons (car b) r))) |
87 | (:else ret)))) | 130 | (setf b (cdr b))) |
88 | (r (gensym))) | 131 | (reverse r))) |
89 | `(let ((,r (cl-block ,pname | 132 | (esym (make-symbol "yoke-error"))) |
90 | (condition-case err | 133 | ;; Body modifiers. These are applied in reverse order (that is, the last |
91 | (progn | 134 | ;; one will be on the outside). |
92 | ;; Pass `:when' or `:unless' clauses | 135 | ;; --- Require the current package |
93 | ,@(cond | 136 | (when req |
94 | ((and whenp unlessp) | 137 | (setf body |
95 | `((when (or (not ,when) ,unless) | 138 | (append (let (reqs) |
96 | (cl-return-from ,pname | 139 | (dolist (r (ensure-list req) reqs) |
97 | (format "%s (abort) :when %S :unless %S" | 140 | (let* ((feat (if (eq r t) name r)) |
98 | ',pname ',when ',unless))))) | 141 | (+feat (intern (format "+%s" feat)))) |
99 | (whenp | 142 | (push `(require ',feat) reqs) |
100 | `((unless ,when (cl-return-from ,pname | 143 | (push `(require ',+feat nil :noerror) reqs))) |
101 | (format "%s (abort) :when %S" | 144 | (reverse reqs)) |
102 | ',pname ',when))))) | 145 | body))) |
103 | (unlessp | 146 | ;; --- Install the package |
104 | `((when ,unless (cl-return-from ,pname | 147 | (when (consp package) |
105 | (format "%s (abort) :unless %S" | 148 | (push `(yoke-install ',(car package) ,@(cdr package)) |
106 | ',pname ',unless)))))) | 149 | body)) |
107 | ;; Evaluate `:pre' forms | 150 | ;; --- Dependencies |
108 | ,@pre | 151 | (when depends |
109 | ;; Get prerequisite packages | 152 | (setf body |
110 | ,@(cl-loop | 153 | (append (cl-loop for dep in (ensure-list depends) |
111 | for (pkg* . yoke-get-args) in depends | 154 | collect `(or (yoke-install ',@(ensure-list dep)) |
112 | collect `(or | 155 | (error "Dependency (%s): %S" |
113 | (let* ((pkg-spec (yoke-get ,@yoke-get-args | 156 | ',dep ',package))) |
114 | :dir ,(format "%s" pkg*))) | 157 | body))) |
115 | (dir (expand-file-name (or (plist-get (cdr pkg-spec) :load) | 158 | ;; --- Load after |
116 | "") | 159 | (when after |
117 | (car pkg-spec)))) | 160 | (setf body `((yoke--eval-after ,(cl-subst name t after) ,@body)))) |
118 | (and dir | 161 | ;; --- Conditional expansion |
119 | ,@(if autoload | 162 | (when (or whenp unlessp) |
120 | `((yoke-generate-autoloads ',pkg* dir)) | 163 | (setf body |
121 | '(t)) | 164 | (append (cond |
122 | (add-to-list 'yoke-dirs dir nil #'string=))) | 165 | ((and whenp unlessp) |
123 | (cl-return-from ,pname | 166 | `((when (or (not ,when) ,unless) |
124 | (format "Error fetching prerequiste: %s" | 167 | (signal 'yoke-predicate |
125 | ',pkg*)))) | 168 | '(:when ,when :unless ,unless))))) |
126 | ;; Download the package, generate autoloads | 169 | (whenp |
127 | ,@(when url | 170 | `((unless ,when (signal 'yoke-predicate |
128 | `((let* ((pkg-spec (yoke-get ,@url :dir ,(format "%s" pkg))) | 171 | '(:when ,when))))) |
129 | (,dirvar (expand-file-name (or (plist-get (cdr pkg-spec) :load) | 172 | (unlessp |
130 | "") | 173 | `((when ,unless (signal 'yoke-predicate |
131 | (car pkg-spec)))) | 174 | '(:unless ,unless)))))) |
132 | ,@(when autoload | 175 | body))) |
133 | `((yoke-generate-autoloads ',pkg ,dirvar))) | 176 | ;; Expansion |
134 | (add-to-list 'yoke-dirs ,dirvar nil #'string=)))) | 177 | `(condition-case ,esym |
135 | ;; Evaluate the body, optionally after the features in `:after' | 178 | (cl-letf (((symbol-function 'package--save-selected-packages) |
136 | ,@(cond (after | 179 | #'ignore)) |
137 | `((yoke-eval-after ,after ,@body))) | 180 | ;; Body |
138 | (:else body))) | 181 | ,@body) |
139 | (:success ',package) | 182 | (:success |
140 | (t (message "%s: %s (%s)" ',pname (car err) (cdr err)) | 183 | ,(unless (atom package) |
141 | nil))))) | 184 | `(setf (alist-get ',name yoke-selected-packages) |
142 | (when (stringp ,r) (message "%S" ,r)) | 185 | (list ,@(cdr-safe package)))) |
143 | ,r))) | 186 | ',package) |
144 | 187 | (t ,(if yoke-debug-on-error | |
145 | (defun yoke-get (url &rest args) | 188 | `(signal (car ,esym) (cdr ,esym)) |
146 | "\"Get\" URL and and put it in DIR, then add DIR to `load-path'. | 189 | `(message "(yoke) %s: %s" (car ,esym) (cdr ,esym))))))) |
147 | URL can be a string or a list of the form (TYPE URL). The | 190 | |
148 | download will be dispatched to the TYPE, or to | 191 | ;;; Installing packages |
149 | `yoke-get-default-fn' if only a string is given. | 192 | |
150 | ARGS is a plist with the following possible keys: | 193 | (defun yoke-install (name &rest args) |
151 | 194 | "Install package NAME, with ARGS." | |
152 | :dir DIRECTORY --- the directory to put the URL. | 195 | (let ((custom-file null-device) |
153 | :load DIRECTORY --- the directory (relative to the download path) | 196 | (inhibit-message (and (not (plist-member args :update)) |
154 | to add to `load-path'. | 197 | (not debug-on-error))) |
155 | :type TYPE --- one of `http', `git', or `file' --- how to | 198 | (messages-buffer-name yoke-message-buffer)) |
156 | download URL." | 199 | (funcall |
157 | (let* ((dir (plist-get args :dir)) | 200 | (intern |
158 | (load (plist-get args :load)) | 201 | (format "yoke-install-%s" |
159 | (type (or (plist-get args :type))) | 202 | (or (plist-get args :backend) |
160 | (path (cond | 203 | (yoke--guess-backend (plist-get args :url)) |
161 | ((eq type 'http) (yoke-get-http url dir)) | 204 | 'package))) |
162 | ((or (eq type 'git) | 205 | name args)) |
163 | (string-match-p (rx bos "git:") url)) | 206 | (yoke--clean-load-path) |
164 | (yoke-get-git url dir)) | 207 | ;; Don't return nil |
165 | ((or (eq type 'file) | 208 | t) |
166 | (string-match-p (rx bos (or "file:" "~" "/")) url)) | 209 | |
167 | (yoke-get-file url dir)) | 210 | (defun yoke-install-package (name args &optional tries) |
168 | ((stringp url) | 211 | "Install package NAME with ARGS using `package' machinery. |
169 | (funcall yoke-get-default-fn url dir)) | 212 | TRIES is an internal variable." |
170 | (:else (error "Uknown URL type: %S" url))))) | 213 | (let ((package-user-dir yoke-directory) |
171 | (cond | 214 | (url (plist-get args :url)) |
172 | ((file-exists-p path) | 215 | (update (plist-get args :update)) |
173 | (add-to-list 'load-path (expand-file-name (or load "") path)) | 216 | (dirname (expand-file-name (format "%s" name) |
174 | (cons path args)) | 217 | yoke-directory)) |
175 | (:else (error "Directory \"%s\" doesn't exist." path) | 218 | (tries (or tries 0)) |
176 | nil)))) | 219 | load-dir autoloads-file-name) |
177 | 220 | (unless (file-exists-p dirname) | |
178 | (defun yoke-get--guess-directory (path &optional dir) | 221 | (setq dirname (or (car-safe (file-expand-wildcards |
179 | "Guess directory from PATH and DIR, and return it. | 222 | (concat dirname "*"))) |
180 | If DIR is present and relative, resolve it relative to | 223 | dirname))) |
181 | `yoke-dir', or if it's absolute, leave it as-is. If DIR is | 224 | (setq load-dir |
182 | absent, return the final component of PATH resolved relative to | 225 | (expand-file-name (or (plist-get args :lisp-dir) "") dirname) |
183 | `yoke-dir'." | 226 | generated-autoload-file |
184 | (expand-file-name (or dir (file-name-nondirectory path)) | 227 | (expand-file-name (format "%s-autoloads.el" name) load-dir)) |
185 | yoke-dir)) | 228 | (prog1 |
186 | 229 | (condition-case error | |
187 | (defun yoke-get-http (url &optional dir) | 230 | (cond |
188 | "Download URL to DIR and return its directory. | 231 | ;; -- Commented on 2022-12-21 |
189 | If DIR isn't given, it's guessed from the final component of the | 232 | ;; ((and (file-exists-p dirname) |
190 | URL's path and placed under `yoke-dir'." | 233 | ;; (not update)) |
191 | (let* ((dir (yoke-get--guess-directory url dir)) | 234 | ;; (add-to-list 'load-path |
192 | (basename (file-name-nondirectory url)) | 235 | ;; (expand-file-name |
193 | ;; XXX: Is this the best idea?? PROBABLY NOT!!! Ideally I'd have | 236 | ;; (or (plist-get args :lisp-dir) "") |
194 | ;; a parameter (either dynamic var or passed in) that would give the | 237 | ;; dirname) |
195 | ;; name of the downloaded file. But that would take a bit of | 238 | ;; nil #'equal) |
196 | ;; re-engineering, I think. So for now, it stays thus. | 239 | ;; (require (intern (format "%s-autoloads" name)))) |
197 | (filename (expand-file-name | 240 | ((and url update) |
198 | (replace-regexp-in-string | 241 | (package-vc-update (cadr (assoc name package-alist)))) |
199 | (rx "-" (+ digit) ; major version | 242 | (update |
200 | (+ (group "." (+ digit))) ; following version numbers | 243 | (package-update name)) |
201 | (group "." (+ (not space)))) ; extension | 244 | (url |
202 | "\\2" | 245 | ;; I'm going to be honest here, this is extremely cursed. But I |
203 | basename) | 246 | ;; don't want to get asked about installing the packages, and when |
204 | dir))) | 247 | ;; the user answers 'no', the function errors. So.. this. |
205 | (cond ((file-exists-p filename) | 248 | (cl-letf (((symbol-function 'yes-or-no-p) #'ignore)) |
206 | dir) | 249 | (ignore-errors (package-vc-install (cons name args))))) |
207 | (:else | 250 | (:else |
208 | (message "Downloading %s..." url) | 251 | (package-install name))) |
209 | (with-current-buffer (let ((url-debug t)) | 252 | (file-error (if (> tries 1) |
210 | (url-retrieve-synchronously url)) | 253 | (error "(yoke) Can't install `%s'" name) |
211 | (condition-case e | 254 | (package-refresh-contents) |
212 | (progn | 255 | (yoke-install-package name args (1+ tries))))) |
213 | (goto-char (point-min)) | 256 | (add-to-list 'load-path load-dir nil #'equal) |
214 | (delete-region (point) (+ 1 (re-search-forward "^$"))) | 257 | (loaddefs-generate load-dir generated-autoload-file) |
215 | (make-directory dir :parents) | 258 | ;; Do it again, if it doesn't actually /generate/ anything |
216 | (write-file filename 1) | 259 | (when (eq 'provide |
217 | (message "Downloading %s... Done" url)) | 260 | (with-current-buffer (find-file-noselect generated-autoload-file) |
218 | (:success dir) | 261 | (read (buffer-substring (point-min) (point-max))))) |
219 | (t (signal (car e) (cdr e))))))))) | 262 | (loaddefs-generate load-dir generated-autoload-file nil nil nil |
220 | 263 | :generate-full)) | |
221 | (defun yoke-get-git (repo &optional dir) | 264 | (load generated-autoload-file :noerror) |
222 | "Clone REPO to DIR and return its directory. | 265 | (kill-buffer (get-file-buffer generated-autoload-file)) |
223 | If DIR isn't given, it's guessed from the repo's name and put | 266 | (package-activate name)))) |
224 | under `yoke-dir'. Return the cloned directory's name on success, | 267 | |
225 | or nil on failure." | 268 | (defun yoke-install-http (name args) |
226 | (let ((dir (yoke-get--guess-directory repo dir))) | 269 | "Install a package NAME using ARGS from an http source." |
227 | (cond ((file-exists-p dir) | 270 | (let* ((url (plist-get args :url)) |
228 | dir) | 271 | (cached (expand-file-name (file-name-nondirectory url) |
229 | (:else | 272 | yoke-cache-directory)) |
230 | (message "Cloning %s..." repo) | 273 | (update (plist-get args :update))) |
231 | (pcase (call-process "git" nil (get-buffer-create yoke-buffer) nil | 274 | (unless url |
232 | "clone" repo dir) | 275 | (error "No URL for HTTP download: %S" (cons name args))) |
233 | (0 (message "Cloning %s... Done" repo) | 276 | (when (or (not (file-exists-p cached)) |
234 | dir) | 277 | update) |
235 | (_ (message "Cloning %s... Error! See buffer %s for output." | 278 | (make-directory yoke-cache-directory :parents) |
236 | repo yoke-buffer) | 279 | (message "Downloading `%s'..." url) |
237 | nil)))))) | 280 | (let* ((url-debug t) |
238 | 281 | (buf (url-retrieve-synchronously url))) | |
239 | (defun yoke-get-file (file &optional _dir) | 282 | (with-current-buffer buf |
240 | "Add FILE's directory to `load-dir'. | 283 | (goto-char (point-min)) |
241 | _DIR is ignored." | 284 | (delete-region (point) (1+ (re-search-forward "^$"))) |
242 | (file-name-directory file)) | 285 | (write-file cached 1) |
243 | 286 | (message "Downloading `%s'...Done." url)))) | |
244 | (defun yoke-generate-autoloads (package dir) | 287 | (package-install-file cached))) |
245 | "Generate autoloads for PACKAGE in DIR." | 288 | |
246 | ;; Shamelessly stolen from `straight'. | 289 | (defun yoke-install-file (name args) |
247 | (eval-and-compile (require 'autoload)) | 290 | "Install package NAME using ARGS from a file on-disk." |
248 | (let ((generated-autoload-file | 291 | (let ((url (plist-get args :url)) |
249 | (expand-file-name (format "%s-autoloads.el" package) dir)) | 292 | (update (plist-get args :update)) |
250 | (backup-inhibited t) | 293 | (dirname (expand-file-name (format "%s" name) yoke-directory))) |
251 | (version-control 'never) | 294 | (if (file-exists-p url) |
252 | (message-log-max nil) | 295 | ;; This takes care of updating too. |
253 | (inhibit-message t)) | 296 | (package-install-file url) |
254 | (unless (file-exists-p generated-autoload-file) | 297 | (error "(yoke) No such file: `%s'" url)))) |
255 | (let ((find-file-hook nil) | 298 | |
256 | (write-file-functions nil) | 299 | ;;; Other package transactions |
257 | (debug-on-error nil) | 300 | |
258 | (left-margin 0)) | 301 | (defun yoke--choose-package () |
259 | (if (fboundp 'make-directory-autoloads) | 302 | "Choose a package from `yoke-selected-packages'." |
260 | (make-directory-autoloads dir generated-autoload-file) | 303 | (assoc (intern (completing-read "Package: " yoke-selected-packages)) |
261 | (and (fboundp 'update-directory-autoloads) | 304 | yoke-selected-packages)) |
262 | (update-directory-autoloads dir))))) | 305 | |
263 | (when-let ((buf (find-buffer-visiting generated-autoload-file))) | 306 | (defun yoke-update (name &rest args) |
264 | (kill-buffer buf)) | 307 | (interactive (yoke--choose-package)) |
265 | (load generated-autoload-file :noerror :nomessage) | 308 | (save-window-excursion |
266 | t)) | 309 | (apply #'yoke-install name (append '(:update t) |
267 | 310 | args)))) | |
268 | ;;; Evaluating forms after features | 311 | |
312 | (defun yoke-update-all () | ||
313 | (interactive) | ||
314 | (dolist (pkg yoke-selected-packages) | ||
315 | (apply #'yoke-update pkg))) | ||
316 | |||
317 | ;;; Emacs integration | ||
318 | |||
319 | (defun yoke-imenu-insinuate () | ||
320 | "Insinuate `yoke' forms for `imenu'." | ||
321 | (require 'imenu) | ||
322 | (setf (alist-get "Yoke" imenu-generic-expression nil nil #'equal) | ||
323 | (list "(yoke[[:space:]]*(?\\([^\t\n )]*\\)" | ||
324 | 1)) | ||
325 | (with-eval-after-load 'consult-imenu | ||
326 | (setf (alist-get ?y (plist-get (alist-get 'emacs-lisp-mode | ||
327 | consult-imenu-config) | ||
328 | :types)) | ||
329 | '("Yoke")))) | ||
330 | |||
331 | ;;; Utility functions | ||
332 | |||
333 | (defun yoke--pget (spec prop &optional default) | ||
334 | "Get PROP's value from SPEC, a yoke specification. | ||
335 | If KEY doesn't exist, return DEFAULT." | ||
336 | (let ((pl (or (and (plistp spec) spec) | ||
337 | (cdr-safe spec)))) | ||
338 | (if (plist-member pl prop) | ||
339 | (plist-get pl prop) | ||
340 | default))) | ||
341 | |||
342 | (defun yoke--guess-backend (url) | ||
343 | "Guess the backend to use from URL. | ||
344 | If inconclusive, return nil." | ||
345 | (cond | ||
346 | ((or (string-prefix-p "file:" url t) | ||
347 | (string-prefix-p "~" url) | ||
348 | (string-prefix-p "/" url)) | ||
349 | 'file) | ||
350 | (:else nil))) | ||
351 | |||
352 | (defun yoke--clean-load-path () | ||
353 | (when-let ((first (string-remove-suffix "/" (car load-path))) | ||
354 | (second (string-remove-suffix "/" (cadr load-path))) | ||
355 | (_ (equal first second))) | ||
356 | (setf load-path (cdr load-path)) | ||
357 | (setf (car load-path) second))) | ||
269 | 358 | ||
270 | (defun yoke--eval-after-init (fn) | 359 | (defun yoke--eval-after-init (fn) |
271 | "Evaluate FN after inititation, or now if Emacs is initialized. | 360 | "Evaluate FN after inititation, or now if Emacs is initialized. |
@@ -274,79 +363,30 @@ FN is called with no arguments." | |||
274 | (funcall fn) | 363 | (funcall fn) |
275 | (add-hook 'after-init-hook fn))) | 364 | (add-hook 'after-init-hook fn))) |
276 | 365 | ||
277 | (defmacro yoke-eval-after (features &rest body) | 366 | (defmacro yoke--eval-after (prereqs &rest body) |
278 | "Evaluate BODY, but only after loading FEATURES. | 367 | "Evaluate body after PREREQS. |
279 | FEATURES can be an atom or a list; as an atom it works like | 368 | PREREQS can be a feature, a number, `:init', or a list of those. |
280 | `with-eval-after-load'. The special feature `init' will evaluate | ||
281 | BODY after Emacs is finished initializing." | ||
282 | (declare (indent 1) | ||
283 | (debug (form def-body))) | ||
284 | (unless (listp features) | ||
285 | (setf features (list features))) | ||
286 | (if (null features) | ||
287 | (macroexp-progn body) | ||
288 | (let* ((this (car features)) | ||
289 | (rest (cdr features))) | ||
290 | (cond ((eq this 'init) | ||
291 | `(yoke--eval-after-init | ||
292 | (lambda () (yoke-eval-after ,rest ,@body)))) | ||
293 | (:else | ||
294 | `(with-eval-after-load ',this | ||
295 | (yoke-eval-after ,rest ,@body))))))) | ||
296 | 369 | ||
297 | ;;; Integration | 370 | Features are used as arguments to `eval-after-load'. Numbers are |
371 | used as arguments to `run-with-idle-timer'. `:init' will ensure BODY | ||
372 | runs after Emacs's init time. | ||
298 | 373 | ||
299 | (defun yoke-imenu-insinuate () | 374 | When given a list of PREREQS, `eval-after' will nest each one |
300 | "Insinuate `yoke' forms for `imenu'." | 375 | from left to right." |
301 | (require 'imenu) | 376 | (declare (indent 1) (debug (form def-body))) |
302 | (setf (alist-get "Yoke" imenu-generic-expression nil nil #'equal) | 377 | (setf prereqs (ensure-list prereqs)) |
303 | (list (rx (: "(yoke" (+ space) (? "(") | 378 | (if (null prereqs) |
304 | (group (+ (not (or "(" " " "\t" "\n")))) | 379 | (macroexp-progn body) |
305 | (* any))) | 380 | (let* ((this (car prereqs)) |
306 | 1))) | 381 | (form `((lambda () (yoke--eval-after ,(cdr prereqs) ,@body))))) |
307 | 382 | (cond | |
308 | ;;; Package maintenance | 383 | ((eq this :init) |
309 | 384 | (append '(yoke--eval-after-init) form)) | |
310 | (defvar yoke--all "*all*" | 385 | ((numberp this) |
311 | "Value that `yoke--prompt-for-package' uses for all packages.") | 386 | (append `(run-with-idle-timer ,this nil) form)) |
312 | 387 | ((symbolp this) | |
313 | (defun yoke--choose-packages (prompt &optional onep) | 388 | (append `(eval-after-load ',this) form)) |
314 | "Choose from all of yoke's installed packages." | 389 | (:else (user-error "Eval-after: Bad prereq: %S" this)))))) |
315 | (funcall (if onep #'completing-read #'completing-read-multiple) | ||
316 | prompt | ||
317 | (cons yoke--all yoke-dirs) | ||
318 | nil :require-match nil nil | ||
319 | (unless onep yoke--all))) | ||
320 | |||
321 | (defun yoke--choices (&optional selections) | ||
322 | "Either the SELECTIONS given, or all of `yoke-dirs'. | ||
323 | If `yoke--all' is part of SELECTIONS, or if it's not given, | ||
324 | return the full list of `yoke-dirs'." | ||
325 | (cond ((or (null selections) | ||
326 | (member yoke--all selections)) | ||
327 | yoke-dirs) | ||
328 | (:else selections))) | ||
329 | |||
330 | (defun yoke-compile (&rest packages) | ||
331 | "Compile all elisp files in `yoke-dirs'." | ||
332 | (interactive (yoke--choose-packages "Compile packages: ")) | ||
333 | (dolist (dir (yoke--choices packages)) | ||
334 | (byte-recompile-directory dir 0))) | ||
335 | |||
336 | (defun yoke-update-autoloads (&rest packages) | ||
337 | "Update the autoloads in PACKAGES' directories." | ||
338 | (interactive (yoke--choose-packages "Generate autoloads for packages: ")) | ||
339 | (dolist (dir (yoke--choices packages)) | ||
340 | (message "Generating autoloads for %s..." dir) | ||
341 | (yoke-generate-autoloads (file-name-nondirectory dir) dir) | ||
342 | (message "Generating autoloads for %s... Done" dir))) | ||
343 | |||
344 | (defun yoke-remove (dir) | ||
345 | "Remove DIR from `yoke-dir'." | ||
346 | (interactive | ||
347 | (list (completing-read "Remove: " yoke-dirs | ||
348 | nil :require-match))) | ||
349 | (delete-directory dir :recursive :trash)) | ||
350 | 390 | ||
351 | (provide 'yoke) | 391 | (provide 'yoke) |
352 | ;;; yoke.el ends here | 392 | ;;; yoke.el ends here |