about summary refs log tree commit diff stats
path: root/lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp')
-rw-r--r--lisp/+browse-url.el189
-rw-r--r--lisp/+cape.el25
-rw-r--r--lisp/+emms.el38
-rw-r--r--lisp/+flyspell-correct.el24
-rw-r--r--lisp/+hungry-delete.el53
-rw-r--r--lisp/+isearch.el24
-rw-r--r--lisp/+ispell.el97
-rw-r--r--lisp/+link-hint.el144
-rw-r--r--lisp/+lisp.el93
-rw-r--r--lisp/+message.el26
-rw-r--r--lisp/+notmuch.el149
-rw-r--r--lisp/+org-capture.el49
-rw-r--r--lisp/+org.el309
-rw-r--r--lisp/+paredit.el26
-rw-r--r--lisp/+titlecase.el34
-rw-r--r--lisp/acdw-defaults.el295
-rw-r--r--lisp/acdw-funs.el262
-rw-r--r--lisp/acdw-macs.el293
-rw-r--r--lisp/acdw.el79
-rw-r--r--lisp/graveyard.el50
-rw-r--r--lisp/init-org.el144
-rw-r--r--lisp/upload-junk.el47
-rw-r--r--lisp/yoke.el392
23 files changed, 0 insertions, 2842 deletions
diff --git a/lisp/+browse-url.el b/lisp/+browse-url.el deleted file mode 100644 index b65b6f9..0000000 --- a/lisp/+browse-url.el +++ /dev/null
@@ -1,189 +0,0 @@
1;;; +browse-url.el -*- lexical-binding: t; -*-
2
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
13
14(cl-defmacro +browse-url-make-external-viewer-handler
15 (viewer
16 &key
17 args
18 (prompt "URL: ")
19 (program (executable-find (format "%s" viewer)))
20 (name (intern (format "+browse-url-with-%s" viewer)))
21 doc
22 (var (intern (format "%s-args" name)))
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.
27This macro also creates a `customize' setting in CUSTOM-GROUP for
28PROGRAM's command-line arguments. ARGS specifies the
29default arguments for this user option.
30
31PROGRAM defaults to the result of calling `executable-find' on VIEWER.
32
33PROMPT is shown to the user in the function's `interactive' spec, as an argument
34to `browse-url-interactive-arg'.
35
36The resulting function is named NAME, which defaults to
37`+browse-url-with-VIEWER'. The custom variable is named VAR, which defaults
38to `NAME-args'. If DOC or VARDOC are provided, they'll be the documentation of
39the function and variable respectively; otherwise a basic default doc-string is
40used.
41
42If FALLBACK is non-nil (the default is `browse-url-generic'), the
43generated function will call FALLBACK if unable to start PROGRAM
44for some reason."
45 (declare (indent 1))
46 `(progn
47 (defcustom ,var ,args
48 ,(or vardoc (format "Arguments to pass to %s in `%s'."
49 viewer name))
50 :type '(repeat :tag "Command-line argument" string)
51 :group ',custom-group)
52 (defun ,name (url &optional new-window)
53 ,(or doc (format "Open URL in %s." viewer))
54 (interactive (browse-url-interactive-arg ,prompt))
55 (let* ((url (browse-url-encode-url url))
56 (process-environment (browse-url-process-environment)))
57 (message ,(format "Opening %%s in %s..." viewer) url)
58 (unless (ignore-errors (apply #'start-process
59 (format "%s %s" ',viewer url)
60 nil
61 ,program
62 (append ,var (list url))))
63 ,@(cond
64 (fallback `((funcall ,fallback url new-window)))
65 (:else `((message "Can't find viewer: %s" ,viewer)
66 nil))))))))
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
82(defcustom +browse-url-download-open t
83 "Whether to open downloaded files after downloading."
84 :type 'boolean)
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
99(defun +browse-url-download-callback (status url dir)
100 ;; A slight change to `eww-download-callback' that returns the downloaded
101 ;; filename.
102 (unless (plist-get status :error)
103 (let* ((obj (url-generic-parse-url url))
104 (path (directory-file-name (car (url-path-and-query obj))))
105 (file (eww-make-unique-file-name
106 (eww-decode-url-file-name (file-name-nondirectory path))
107 dir)))
108 (goto-char (point-min))
109 (re-search-forward "\r?\n\r?\n")
110 (let ((coding-system-for-write 'no-conversion))
111 (write-region (point) (point-max) file))
112 (message "Saved %s" file)
113 file)))
114
115;;; URL matcher generators
116
117(defun +browse-url-matches (&rest regexps)
118 "Return a lambda that will determine if a url matches REGEXPS.
119Each regexp will be tested in turn. The first one that matches
120is returned by the lambda.
121
122This is a good function to use in key positions in `browse-url-handlers'."
123 `(lambda (url &optional new-window)
124 (cl-loop for regexp in ',regexps
125 if (string-match-p regexp url)
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'.
134This is just a list of strings. They'll be regexp-escaped and
135passed to `+browse-url-external-url-p', which is a good function
136to put in `browse-url-handlers'.
137
138If an item in this list is a list itself, it should contain one string, a valid
139regexp 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'.
146This 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.
159URL-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'.
164This 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)))))))
187
188(provide '+browse-url)
189;;; +browse-url.el ends here
diff --git a/lisp/+cape.el b/lisp/+cape.el deleted file mode 100644 index 37e88fe..0000000 --- a/lisp/+cape.el +++ /dev/null
@@ -1,25 +0,0 @@
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.
9Add a function to HOOK that will add CAPES to the local
10`completion-at-point-functions' for that mode's buffer. If CAPFS
11are 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/+emms.el b/lisp/+emms.el deleted file mode 100644 index a43daea..0000000 --- a/lisp/+emms.el +++ /dev/null
@@ -1,38 +0,0 @@
1;;; +emms.el -*- lexical-binding: t; -*-
2
3(defun +emms-streams (&optional file)
4 "Better interface for `emms-streams'.
5If FILE is non-nil, use it. Otherwise use `emms-streams-file'.
6If `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/+flyspell-correct.el b/lisp/+flyspell-correct.el deleted file mode 100644 index 9a33cc0..0000000 --- a/lisp/+flyspell-correct.el +++ /dev/null
@@ -1,24 +0,0 @@
1;;; +flyspell-correct.el --- -*- lexical-binding: t; -*-
2
3;;; Code:
4
5(require 'flyspell-correct)
6
7(defun +flyspell-correct-buffer (&optional prefix)
8 "Run `flyspell-correct-wrapper' on all misspelled words in the buffer.
9With PREFIX, prompt to change the current dictionary."
10 (interactive "P")
11 (flyspell-buffer)
12 (when prefix
13 (let ((current-prefix-arg nil))
14 (call-interactively #'ispell-change-dictionary)))
15 (with-message "Checking spelling"
16 (flyspell-correct-move (point-min) :forward :rapid)))
17
18(defun +flyspell-correct-buffer-h (&rest _)
19 "Run `+flyspell-correct-buffer'.
20This is suitable for placement in a hook."
21 (+flyspell-correct-buffer))
22
23(provide '+flyspell-correct)
24;;; +flyspell-correct.el ends here
diff --git a/lisp/+hungry-delete.el b/lisp/+hungry-delete.el deleted file mode 100644 index 601aecf..0000000 --- a/lisp/+hungry-delete.el +++ /dev/null
@@ -1,53 +0,0 @@
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.
11If the adjacent characters in DIRECTION are one of
12`hungry-delete-chars-to-skip', call HD-FUNC. Otherwise, call
13FUNC.
14
15If DIRECTION is a positive integer or `forward', look forward.
16If it's negative or `backward', look backward. If it's absent,
17this macro will try to guess based on the names of FUNC and
18HD-FUNC.
19
20This macro creates a function taking a prefix argument that's
21passed 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 deleted file mode 100644 index 3516ec4..0000000 --- a/lisp/+isearch.el +++ /dev/null
@@ -1,24 +0,0 @@
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.
7This 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'.
13This 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/+ispell.el b/lisp/+ispell.el deleted file mode 100644 index 10c31b8..0000000 --- a/lisp/+ispell.el +++ /dev/null
@@ -1,97 +0,0 @@
1;;; +ispell.el --- Customizations for `ispell' -*- lexical-binding: t; -*-
2
3;;; Commentary:
4
5;;; Code:
6
7(require 'cl-lib)
8(require 'seq)
9
10;; Utility function TODO: move elsewhere
11(defun +ispell-append-removing-duplicates (&rest lists)
12 "Append LISTS, removing duplicates from the result.
13Any keyword arguments to `cl-remove-duplicates' should come
14before the LISTS."
15 (let (cl-remove-duplicates-args)
16 (while (keywordp (car lists))
17 (push (pop lists) cl-remove-duplicates-args)
18 (push (pop lists) cl-remove-duplicates-args))
19 (apply #'cl-remove-duplicates (apply #'append lists)
20 (nreverse cl-remove-duplicates-args))))
21
22;;; Ispell in .dir-locals
23
24;; Let Emacs know a list of strings is safe
25(defun +ispell-safe-local-p (list)
26 (and (listp list)
27 (seq-every-p #'stringp list)))
28
29;; Can I instruct ispell to insert LocalWords in a different file?
30;; https://emacs.stackexchange.com/q/31396/2264
31
32;; How can I move all my file-local LocalWords to .dir-locals.el?
33;; https://emacs.stackexchange.com/q/31419
34
35;; Adapted from ispell.el:ispell-buffer-local-words
36(defun +ispell-buffer-local-words-list ()
37 (let (words)
38 (or ispell-buffer-local-name
39 (setf ispell-buffer-local-name (buffer-name)))
40 (save-excursion
41 (goto-char (point-min))
42 (while (search-forward ispell-words-keyword nil t)
43 (let ((end (point-at-eol))
44 (ispell-casechars (ispell-get-casechars))
45 string)
46 (while (re-search-forward " *\\([^ ]+\\)" end t)
47 (setf string (match-string-no-properties 1))
48 (if (and (< 1 (length string))
49 (equal 0 (string-match ispell-casechars string)))
50 (push string words))))))
51 words))
52
53;;;###autoload
54(defun +ispell-move-buffer-words-to-dir-locals (&optional arg)
55 "Move the current buffer-local words to .dir-locals.el.
56This function prompts the user to save .dir-locals.el, unless
57prefix ARG is non-nil; then it just saves them."
58 (interactive "P")
59 (unless (buffer-file-name)
60 (user-error "Buffer not attached to file"))
61 (hack-dir-local-variables)
62 (let ((print-level nil)
63 (print-length nil))
64 (when-let ((new-words (cl-remove-if (lambda (el) (eq el '\.\.\.)) ; XXX: NO IDEA
65 ; where this came from
66 (+ispell-append-removing-duplicates
67 :test #'string=
68 ispell-buffer-session-localwords
69 (alist-get 'ispell-buffer-session-localwords
70 dir-local-variables-alist)
71 (alist-get 'ispell-buffer-session-localwords
72 file-local-variables-alist)
73 (+ispell-buffer-local-words-list)))))
74 (save-excursion
75 (add-dir-local-variable
76 major-mode
77 'ispell-buffer-session-localwords
78 (setf ispell-buffer-session-localwords
79 new-words))
80 (when (or arg
81 (y-or-n-p "Save .dir-locals.el?"))
82 (save-buffer))
83 (bury-buffer))
84 (or ispell-buffer-local-name
85 (setf ispell-buffer-local-name (buffer-name)))
86 (save-excursion
87 (goto-char (point-min))
88 (while (search-forward ispell-words-keyword nil t)
89 (delete-region (point-at-bol) (1+ (point-at-eol))))))))
90
91;;;###autoload
92(defun +ispell-move-buffer-words-to-dir-locals-hook ()
93 "Convenience function for binding to a hook."
94 (+ispell-move-buffer-words-to-dir-locals t))
95
96(provide '+ispell)
97;;; +ispell.el ends here
diff --git a/lisp/+link-hint.el b/lisp/+link-hint.el deleted file mode 100644 index 926a266..0000000 --- a/lisp/+link-hint.el +++ /dev/null
@@ -1,144 +0,0 @@
1;;; +link-hint.el -*- lexical-binding: t; -*-
2
3;;; Code:
4
5(require 'cl-lib)
6(require 'link-hint)
7
8(defgroup +link-hint nil
9 "Extra customizations for `link-hint'."
10 :group 'link-hint)
11
12(defcustom +link-hint-open-secondary-types '(gnus-w3m-image-url
13 gnus-w3m-url
14 markdown-link
15 mu4e-attachment
16 mu4e-url
17 notmuch-hello
18 nov-link
19 org-link
20 shr-url
21 text-url
22 w3m-link
23 w3m-message-link)
24 "Link types to define `:open-secondary' for.")
25
26(defvar +link-hint-map (make-sparse-keymap)
27 "Keymap for `link-hint' functionality.")
28
29(cl-defmacro +link-hint-define-keyword (keyword handler docstring
30 &optional (types 'link-hint-types)
31 &rest rest
32 &key multiple &allow-other-keys)
33 "Set up a `link-hint' KEYWORD, with optional TYPES.
34If TYPES is not present, use `link-hint-types'.
35
36KEYWORD defines the link-hint type. It will be used to create a
37function for opening links of the form \"link-hint-openKEYWORD\".
38
39HANDLER is the function to open a link with.
40
41DOCSTRING is the macro's documentation.
42
43Keyword arguments are passed to `link-hint-define-type' prefixed
44with the KEYWORD."
45 (declare (indent 2)
46 (doc-string 3))
47 (let ((types (symbol-value types))
48 (func-sym (intern (format "+link-hint-open%s" keyword)))
49 (mult-sym (intern (format "%s-multiple" keyword)))
50 (expr))
51 ;; Define the type
52 (push `(dolist (type ',types)
53 (link-hint-define-type type
54 ,keyword ,handler
55 ,@(mapcar (lambda (el)
56 (if (eq el :multiple)
57 mult-sym
58 el))
59 rest)))
60 expr)
61 ;; Define an opener
62 (push `(defun ,func-sym ()
63 ,(format "%s\n\nDefined by `+link-hint-define'." docstring)
64 (interactive)
65 (avy-with link-hint-open-link
66 (link-hint--one ,keyword)))
67 expr)
68 ;; Handle `:multiple'
69 (when multiple
70 (push `(defun ,(intern (format "+link-hint-open-multiple%s" keyword)) ()
71 ,(format "Open multiple links with `%s'.\n\nDefined by `+link-hint-define'."
72 func-sym)
73 (avy-with link-hint-open-multiple-links
74 (link-hint--multiple ,keyword)))
75 expr)
76 (push `(defun ,(intern (format "+link-hint-open-all%s" keyword)) ()
77 ,(format "Open all visible links with `%s'.\n\nDefined by `+link-hint-define'."
78 func-sym)
79 (avy-with link-hint-open-all-links
80 (link-hint--all ,keyword)))
81 expr))
82 ;; Return the built expression
83 `(progn ,@(nreverse expr))))
84
85(+link-hint-define-keyword :secondary browse-url-secondary-browser-function
86 "Open a link in the secondary browser."
87 +link-hint-open-secondary-types
88 :multiple t)
89
90(defun +link-hint-open-secondary-setup (&optional types)
91 "Define the `:open-secondary' link-hint type for TYPES.
92If TYPES is nil, define it for `+link-hint-open-secondary-types'."
93 (dolist (type (or types +link-hint-open-secondary-types))
94 (link-hint-define-type type
95 :open-secondary browse-url-secondary-browser-function
96 :open-secondary-multiple t)))
97
98(defun +link-hint-open-secondary ()
99 "Open a link in the secondary browser."
100 (interactive)
101 (avy-with link-hint-open-link
102 (link-hint--one :open-secondary)))
103
104(defun +link-hint-open-chrome-setup (&optional types)
105 "Define the `:open-chrome' link-hint type for TYPES.
106If TYPES is nil, define it for `+link-hint-open-secondary-types'."
107 (dolist (type (or types +link-hint-open-secondary-types))
108 (link-hint-define-type type
109 :open-chrome #'browse-url-chrome
110 :open-chrome-multiple t)))
111
112(defun +link-hint-open-chrome ()
113 "Open a link with chrome."
114 (interactive)
115 (avy-with link-hint-open-link
116 (link-hint--one :open-chrome)))
117
118(defun +link-hint-open-link (prefix)
119 "Open a link.
120Without a PREFIX, open using `browse-url-browser-function'; with
121a PREFIX, use `browse-url-secondary-browser-function'."
122 (interactive "P")
123 (let ((current-prefix-arg nil))
124 (avy-with link-hint-open-link
125 (link-hint--one (if prefix :open-secondary :open)))))
126
127(defun +link-hint-open-multiple-links (prefix)
128 "Open multiple links.
129Without a PREFIX, open using `browse-url-browser-function'; with
130a PREFIX, use `browse-url-secondary-browser-function'."
131 (interactive "P")
132 (avy-with link-hint-open-multiple-links
133 (link-hint--one (if prefix :open-secondary :open))))
134
135(defun +link-hint-open-all-links (prefix)
136 "Open all visible links.
137Without a PREFIX, open using `browse-url-browser-function'; with
138a PREFIX, use `browse-url-secondary-browser-function'."
139 (interactive "P")
140 (avy-with link-hint-open-all-links
141 (link-hint--one (if prefix :open-secondary :open))))
142
143(provide '+link-hint)
144;;; +link-hint.el ends here
diff --git a/lisp/+lisp.el b/lisp/+lisp.el deleted file mode 100644 index 22450f7..0000000 --- a/lisp/+lisp.el +++ /dev/null
@@ -1,93 +0,0 @@
1;;; +lisp.el -*- lexical-binding: t -*-
2
3;;; Comment-or-uncomment-sexp
4;; from https://endlessparentheses.com/a-comment-or-uncomment-sexp-command.html
5
6(defun +lisp-uncomment-sexp (&optional n)
7 "Uncomment N sexps around point."
8 (interactive "P")
9 (let* ((initial-point (point-marker))
10 (inhibit-field-text-motion t)
11 (p)
12 (end (save-excursion
13 (when (elt (syntax-ppss) 4)
14 (re-search-backward comment-start-skip
15 (line-beginning-position)
16 t))
17 (setq p (point-marker))
18 (comment-forward (point-max))
19 (point-marker)))
20 (beg (save-excursion
21 (forward-line 0)
22 (while (and (not (bobp))
23 (= end (save-excursion
24 (comment-forward (point-max))
25 (point))))
26 (forward-line -1))
27 (goto-char (line-end-position))
28 (re-search-backward comment-start-skip
29 (line-beginning-position)
30 t)
31 (ignore-errors
32 (while (looking-at-p comment-start-skip)
33 (forward-char -1)))
34 (point-marker))))
35 (unless (= beg end)
36 (uncomment-region beg end)
37 (goto-char p)
38 ;; Indentify the "top-level" sexp inside the comment.
39 (while (and (ignore-errors (backward-up-list) t)
40 (>= (point) beg))
41 (skip-chars-backward (rx (syntax expression-prefix)))
42 (setq p (point-marker)))
43 ;; Re-comment everything before it.
44 (ignore-errors
45 (comment-region beg p))
46 ;; And everything after it.
47 (goto-char p)
48 (forward-sexp (or n 1))
49 (skip-chars-forward "\r\n[:blank:]")
50 (if (< (point) end)
51 (ignore-errors
52 (comment-region (point) end))
53 ;; If this is a closing delimiter, pull it up.
54 (goto-char end)
55 (skip-chars-forward "\r\n[:blank:]")
56 (when (eq 5 (car (syntax-after (point))))
57 (delete-indentation))))
58 ;; Without a prefix, it's more useful to leave point where
59 ;; it was.
60 (unless n
61 (goto-char initial-point))))
62
63(defun +lisp-comment-sexp--raw ()
64 "Comment the sexp at point or ahead of point."
65 (pcase (or (bounds-of-thing-at-point 'sexp)
66 (save-excursion
67 (skip-chars-forward "\r\n[:blank:]")
68 (bounds-of-thing-at-point 'sexp)))
69 (`(,l . ,r)
70 (goto-char r)
71 (skip-chars-forward "\r\n[:blank:]")
72 (save-excursion
73 (comment-region l r))
74 (skip-chars-forward "\r\n[:blank:]"))))
75
76(defun +lisp-comment-or-uncomment-sexp (&optional n)
77 "Comment the sexp at point and move past it.
78If already inside (or before) a comment, uncomment instead.
79With a prefix argument N, (un)comment that many sexps."
80 (interactive "P")
81 (if (or (elt (syntax-ppss) 4)
82 (< (save-excursion
83 (skip-chars-forward "\r\n[:blank:]")
84 (point))
85 (save-excursion
86 (comment-forward 1)
87 (point))))
88 (+lisp-uncomment-sexp n)
89 (dotimes (_ (or n 1))
90 (+lisp-comment-sexp--raw))))
91
92(provide '+lisp)
93;;; +lisp.el ends here
diff --git a/lisp/+message.el b/lisp/+message.el deleted file mode 100644 index b8bc234..0000000 --- a/lisp/+message.el +++ /dev/null
@@ -1,26 +0,0 @@
1;;; +message.el --- Extra message-mode functions -*- lexical-binding: t; -*-
2
3;;; Commentary:
4
5;;; Code:
6
7;; Thanks to Alex Schroeder for this!
8;; https://www.emacswiki.org/emacs/Change_Signature_Dynamically
9
10(defun +message-check-for-signature-change (&rest ignore)
11 "Check for a change in the To: or Cc: fields"
12 (when (and (message--in-tocc-p)
13 (not (buffer-narrowed-p)))
14 (save-excursion
15 (goto-char (point-max))
16 (let ((end (point)))
17 (when (re-search-backward message-signature-separator nil t)
18 (delete-region (1- (match-beginning 0)) end)))
19 (message-insert-signature))))
20
21(defun +message-signature-setup ()
22 (make-local-variable 'after-change-functions)
23 (push '+message-check-for-signature-change after-change-functions))
24
25(provide '+message)
26;;; +message.el ends here
diff --git a/lisp/+notmuch.el b/lisp/+notmuch.el deleted file mode 100644 index 5df6e5b..0000000 --- a/lisp/+notmuch.el +++ /dev/null
@@ -1,149 +0,0 @@
1;;; +notmuch.el --- Notmuch extras -*- lexical-binding: t; -*-
2
3;;; Commentary:
4
5;; This is stuff that I suppose /could/ go in notmuch/init.el, but ... doesn't.
6
7;;; Code:
8
9(require 'cl-lib)
10(require 'notmuch)
11
12(defvar +notmuch-send-dispatch-rules nil
13 "Alist of from addresses and variables to set when sending.")
14
15(defun +notmuch-query-concat (&rest queries)
16 "Concatenate notmuch queries."
17 (mapconcat #'identity queries " AND "))
18
19(defun +send-mail-dispatch ()
20 "Dispatch mail sender, depending on account."
21 (let ((from (message-fetch-field "from")))
22 (dolist (vars (cl-loop for (addr . vars) in +notmuch-send-dispatch-rules
23 if (string-match-p addr from) return vars))
24 (set (car vars) (cdr vars)))))
25
26(defun +notmuch-correct-tags (args)
27 (list (car args) (mapcar #'string-trim (cadr args))))
28
29(defun +notmuch-goto (&optional prefix)
30 "Go straight to a `notmuch' search.
31Without PREFIX argument, go to the first one in
32`notmuch-saved-searches'; with a PREFIX argument, prompt the user
33for which saved search to go to; with a double PREFIX
34argument (\\[universal-argument] \\[universal-argument]), prompt
35for search."
36 (interactive "P")
37 (pcase prefix
38 ('nil (notmuch-search (plist-get (car notmuch-saved-searches) :query)))
39 ('(4) (notmuch-search (plist-get (cl-find (completing-read "Saved Search: "
40 (mapcar (lambda (el)
41 (plist-get el :name))
42 notmuch-saved-searches))
43 notmuch-saved-searches
44 :key (lambda (el) (plist-get el :name))
45 :test #'equal)
46 :query)))
47 (_ (notmuch-search))))
48
49;; Don't add an initial input when completing addresses
50(eval-after notmuch
51 (cond ((featurep 'el-patch)
52 (el-patch-feature notmuch)
53 (el-patch-defun notmuch-address-selection-function (prompt collection initial-input)
54 "Call (`completing-read'
55 PROMPT COLLECTION nil nil INITIAL-INPUT 'notmuch-address-history)"
56 (completing-read
57 prompt collection nil nil
58 (el-patch-swap initial-input
59 nil)
60 'notmuch-address-history)))
61 (:else
62 (defun notmuch-address-selection-function (prompt collection initial-input)
63 "Call (`completing-read'
64 PROMPT COLLECTION nil nil INITIAL-INPUT 'notmuch-address-history)"
65 (completing-read
66 prompt collection nil nil nil
67 'notmuch-address-history)))))
68
69(defcustom +notmuch-spam-tags '("+spam" "+Spam")
70 "A list of tag changes to apply when marking a thread as spam."
71 :type '(repeat string))
72
73(defun +notmuch-tree-mark-spam-then-next (&optional ham beg end)
74 "Mark the current message as spam and move to the next."
75 (interactive "P")
76 (+notmuch-tree-mark-spam ham)
77 (notmuch-tree-next-matching-message))
78
79(defun +notmuch-tree-mark-spam (&optional ham)
80 "Mark the current message as spam.
81That is, apply the tag changes in `+notmuch-spam-tags' to it. If
82an optional prefix HAM argument is given, the message will be
83marked as not-spam (\"ham\"), i.e., the tag changes in
84`+notmuch-spam-tags' will be reversed."
85 (interactive "P")
86 (when +notmuch-spam-tags
87 (notmuch-tree-tag
88 (notmuch-tag-change-list +notmuch-spam-tags ham))))
89
90(defun +notmuch-search-mark-spam (&optional ham beg end)
91 "Mark the current thread or region as spam.
92This adds the tags in `+notmuch-spam-tags' to the message. With
93an optional HAM prefix argument, mark the messages as
94not-spam (\"ham\").
95
96This function advances the next thread when finished."
97 (interactive (cons current-prefix-arg (notmuch-interactive-region)))
98 (when +notmuch-spam-tags
99 (notmuch-search-tag
100 (notmuch-tag-change-list +notmuch-spam-tags ham) beg end))
101 (when (eq beg end)
102 (notmuch-search-next-thread)))
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.
126NAME, KEY, and SEARCH-TYPE are paired with the corresponding keywords in
127`notmuch-saved-searches', which see. QUERIES are all concatenated together with
128AND. If QUERIES is prepended with more keyword arguments, those are added to
129the 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
148(provide '+notmuch)
149;;; +notmuch.el ends here
diff --git a/lisp/+org-capture.el b/lisp/+org-capture.el deleted file mode 100644 index 2f7bf6a..0000000 --- a/lisp/+org-capture.el +++ /dev/null
@@ -1,49 +0,0 @@
1;;; +org-capture.el -*- lexical-binding: t; -*-
2
3;;; Code:
4
5(require 'cl-lib)
6;; Don't /require/ `org-capture', since that'll pull in all of `org' and that'll
7;; take a minute. Just let the compiler know that this variable exists.
8(defvar org-capture-templates nil)
9
10;; https://github.com/cadadr/configuration/blob/39813a771286e542af3aa333172858532c3bb257/emacs.d/gk/gk-org.el#L1573
11(defun +org-capture-template-define (description &rest args)
12 "Define a capture template.
13Creates a list and adds it to `org-capture-templates', if it's
14not already there. ARGS is a plist, which in addition to the
15additional options `org-capture-templates' accepts (which see),
16takes the following and puts them in the right spot: `:keys',
17`:description', `:type', `:target', and `:template'."
18 (declare (indent 1))
19 (let* ((keys (plist-get args :keys))
20 (type (plist-get args :type))
21 (target (plist-get args :target))
22 (template (plist-get args :template))
23 (template-value (append
24 (list description)
25 (when (or type target template)
26 (list (or type 'entry) target template))
27 (cl-loop for i from 0 below (length args) by 2
28 unless (member (nth i args)
29 '(:keys :description :type
30 :target :template))
31 append (list (nth i args)
32 (plist-get args (nth i
33 args)))))))
34 ;; The only way I know how to do this properly (add a value to the end of
35 ;; the list, if it exists; otherwise update it) is to do this weird if-setf
36 ;; dance.
37 (if (seq-find (lambda (el) (equal (car el) keys))
38 org-capture-templates)
39 (setf (alist-get keys org-capture-templates nil nil #'equal)
40 template-value)
41 (setf org-capture-templates
42 (append org-capture-templates
43 (list (cons keys template-value)))))
44 ;; Regardless of what we do, return the new value of
45 ;; `org-capture-templates'.
46 org-capture-templates))
47
48(provide '+org-capture)
49;;; +org-capture.el
diff --git a/lisp/+org.el b/lisp/+org.el deleted file mode 100644 index a148bd8..0000000 --- a/lisp/+org.el +++ /dev/null
@@ -1,309 +0,0 @@
1;;; +org.el -*- lexical-binding: t; -*-
2
3;;; Code:
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/
11
12(defun +org-element-descendant-of (type element)
13 "Return non-nil if ELEMENT is a descendant of TYPE.
14TYPE should be an element type, like `item' or `paragraph'.
15ELEMENT should be a list like that returned by `org-element-context'."
16 ;; MAYBE: Use `org-element-lineage'.
17 (when-let* ((parent (org-element-property :parent element)))
18 (or (eq type (car parent))
19 (+org-element-descendant-of type parent))))
20
21(defun +org-return-dwim (&optional prefix)
22 "A helpful replacement for `org-return'.
23With PREFIX, call `org-return'."
24 (interactive "P")
25 ;; Auto-fill if enabled
26 (when auto-fill-function
27 (dolist (func (ensure-list auto-fill-function))
28 (funcall func)))
29 (cond
30 (prefix ; Handle prefix
31 (pcase prefix
32 ('(4) (newline))
33 ('(16) (newline 2))
34 (_ (newline prefix))))
35 ((and org-return-follows-link ; Open link
36 (eq 'link (car (org-element-context))))
37 (org-open-at-point-global))
38 ((org-at-heading-p) ; Open a line after a heading
39 (let ((heading-start (org-entry-beginning-position)))
40 (goto-char (org-entry-end-position))
41 (cond ((and (org-at-heading-p)
42 (= heading-start (org-entry-beginning-position)))
43 ;; Entry ends on its heading, so add 2 newlines
44 (end-of-line)
45 (newline 2))
46 (t
47 ;; Entry ends after its heading, so back up
48 (forward-line -1)
49 (end-of-line)
50 (when (org-at-heading-p)
51 (forward-line)
52 (newline)
53 (forward-line -1))
54 (while (not (looking-back (rx (repeat 3 (seq (optional blank) "\n")))
55 nil))
56 (newline))
57 (forward-line -1)))))
58 ((org-at-item-checkbox-p) ; Insert a new checkbox item
59 (end-of-line)
60 (org-insert-todo-heading nil))
61 ((org-in-item-p) ; Insert a new list item
62 (let* ((context (org-element-context))
63 (first-item-p (eq 'plain-list (car context)))
64 (itemp (eq 'item (car context)))
65 (emptyp (or
66 ;; This (regular) list item is empty
67 (eq (org-element-property :contents-begin context)
68 (org-element-property :contents-end context))
69 ;; This (definition) list item is empty
70 (looking-at " *::")))
71 (item-child-p (+org-element-descendant-of 'item context)))
72 (cond ((and itemp emptyp)
73 (delete-region (line-beginning-position) (line-end-position))
74 (newline))
75 ((or first-item-p
76 (and itemp (not emptyp))
77 item-child-p)
78 (org-end-of-item)
79 (org-insert-item))
80 (t
81 (delete-region (line-beginning-position) (line-end-position))
82 (newline)))))
83 ((and (fboundp 'org-inlinetask-in-task-p) ; Don't insert a new heading with
84 (org-inlinetask-in-task-p)) ; inline tasks
85 (org-return))
86 ((org-at-table-p) ; Insert a new org-table row
87 (cond ((save-excursion
88 (beginning-of-line)
89 (cl-loop with end = (line-end-position)
90 for cell = (org-element-table-cell-parser)
91 always (equal (org-element-property :contents-begin cell)
92 (org-element-property :contents-end cell))
93 while (re-search-forward "|" end t)))
94 ;; Empty row: end the table
95 (delete-region (line-beginning-position) (line-end-position))
96 (org-return))
97 (t
98 ;; Non-empty row
99 (org-return))))
100 (t ; Otherwise---just call `org-return'.
101 (org-return))))
102
103(defun +org-table-copy-down|+org-return-dwim (&optional n)
104 "Call `org-table-copy-down' or `+org-return' depending on context."
105 (interactive "P")
106 (if (org-table-check-inside-data-field 'noerror)
107 (org-table-copy-down (or n 1))
108 (+org-return-dwim n)))
109
110
111;;; A ... different ... `org-open-at-point-dwim'
112;; I honestly don't remember what the difference is between this and the
113;; O.G. one is.. hopefully this one fixes annoying stupid problems.
114
115(defun +org-open-at-point-dwim (&optional arg)
116 "Open thing at point, or if there isn't something, list things."
117 (interactive "P")
118 (save-excursion
119 (let* ((this-char-type (org-element-type (org-element-context)))
120 (prev-char-type (ignore-errors
121 (save-excursion
122 (backward-char)
123 (org-element-type (org-element-context)))))
124 (types '(citation citation-reference clock comment comment-block
125 footnote-definition footnote-reference headline
126 inline-src-block inlinetask keyword link
127 node-property planning src-block timestamp))
128 (type this-char-type))
129 (when (and (memq this-char-type types) (memq prev-char-type types))
130 (backward-char)
131 (setq type prev-char-type)) ; what the fuckckckckck
132 ;; Okay, so this ^ is pretty janky and doesn't /really/ work that well,
133 ;; especially on DEADLINE (and probably SCHEDULED) lines. However, since
134 ;; I really just want to open the list of URLs /most of the time/, I'm
135 ;; fixing it like this instead.
136 (unless (and (memq type types)
137 (ignore-errors (org-open-at-point arg)
138 t))
139 (while (not
140 (progn
141 (org-back-to-heading)
142 (car (org-offer-links-in-entry (current-buffer) (point) 1))))
143 (org-up-heading-all 1))
144 (org-open-at-point arg)))))
145
146;;; Faces
147;; see `org-emphasis-alist'
148
149(defface org-bold '((t (:weight bold)))
150 "Bold face in `org-mode' documents.")
151
152(defface org-italic '((t (:slant italic)))
153 "Italic face in `org-mode' documents.")
154
155(defface org-underline '((t (:underline t)))
156 "Underline face in `org-mode' documents.")
157
158(defface org-strikethrough '((t (:strike-through t)))
159 "Strike-through face for `org-mode' documents.")
160
161;;; Unsmartify
162
163(defun +org-unsmartify ()
164 "Replace \"smart\" punctuation with their \"dumb\" counterparts."
165 (interactive)
166 (save-excursion
167 (goto-char (point-min))
168 (while (re-search-forward "[“”‘’–—]" nil t)
169 (let ((replace (pcase (match-string 0)
170 ((or "“" "”") "\"")
171 ((or "‘" "’") "'")
172 ("–" "--")
173 ("—" "---"))))
174 (replace-match replace nil nil)))))
175
176;;; Copy org trees as HTML
177;; Thanks to Oleh Krehel:
178;; https://emacs.stackexchange.com/questions/54292/copy-results-of-org-export-directly-to-clipboard
179
180(defun +org-export-clip-to-html
181 (&optional async subtreep visible-only body-only ext-plist post-process)
182 "Export region to HTML, and copy it to the clipboard.
183Arguments ASYNC, SUBTREEP, VISIBLE-ONLY, BODY-ONLY, EXT-PLIST,
184and POST-PROCESS are passed to `org-export-to-file'."
185 (interactive) ; XXX: hould this be interactive?
186 (message "Exporting Org to HTML...")
187 (let ((org-tmp-file "/tmp/org.html"))
188 (org-export-to-file 'html org-tmp-file
189 async subtreep visible-only body-only ext-plist post-process)
190 ;; XXX: figure out which clipboard to use, or use something in Emacs
191 (start-process "xclip" "*xclip*"
192 "xclip" "-verbose"
193 "-i" org-tmp-file
194 "-t" "text/html"
195 "-selection" "clipboard"))
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
206(defun +org-hide-drawers-except-point ()
207 "Hide all drawers except for the one point is in."
208 ;; Most of this bit is taken from `org-fold--hide-drawers'.
209 (let ((pt (point))
210 (begin (point-min))
211 (end (point-max)))
212 (save-excursion
213 (goto-char begin)
214 (while (and (< (point) end)
215 (re-search-forward org-drawer-regexp end t))
216 (if (org-fold-folded-p nil 'drawer)
217 (goto-char (org-fold-next-folding-state-change 'drawer nil end))
218 (let* ((drawer (org-element-at-point))
219 (type (org-element-type drawer))
220 (el-begin (org-element-property :begin drawer))
221 (el-end (org-element-property :end drawer)))
222 (when (memq type '(drawer property-drawer))
223 (org-fold-hide-drawer-toggle
224 (if (< el-begin pt el-end) 'off 'on)
225 nil drawer)
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.
232A function named `+org-link-TYPE-open' will be created, with ARGS
233as its arguments and BODY as its body. BODY can be blank, in
234which case the user will be messaged (This is a good do-nothing
235effect 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.
267Pre-fill the input with clipboard contents if they match CLIPBOARDP. If
268CLIPBOARDP is nil or missing, don't pre-fill.
269
270If INSERT is non-nil, insert the property into the property
271drawer of the current org tree.
272
273If 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))))
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))))))
307
308(provide '+org)
309;;; +org.el ends here
diff --git a/lisp/+paredit.el b/lisp/+paredit.el deleted file mode 100644 index ab176b8..0000000 --- a/lisp/+paredit.el +++ /dev/null
@@ -1,26 +0,0 @@
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/+titlecase.el b/lisp/+titlecase.el deleted file mode 100644 index 6defda7..0000000 --- a/lisp/+titlecase.el +++ /dev/null
@@ -1,34 +0,0 @@
1;;; +titlecase.el --- Titlecase extras -*- lexical-binding: t; -*-
2
3;;; Commentary:
4
5;;; Code:
6
7(require 'titlecase)
8
9(defun +titlecase-sentence-style-dwim (&optional arg)
10 "Titlecase a sentence.
11With prefix ARG, toggle the value of
12`titlecase-downcase-sentences' before sentence-casing."
13 (interactive "P")
14 (let ((titlecase-downcase-sentences (if arg (not titlecase-downcase-sentences)
15 titlecase-downcase-sentences)))
16 (titlecase-dwim 'sentence)))
17
18(defun +titlecase-org-headings ()
19 (interactive)
20 (save-excursion
21 (goto-char (point-min))
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
24 ;; `titlecase-line' to ignore org-mode metadata (TODO cookies, tags, etc).
25 (let ((level (funcall outline-level))
26 (org-special-ctrl-a/e t))
27 (while (and (progn (outline-next-heading)
28 (> (funcall outline-level) level))
29 (not (eobp)))
30 (titlecase-region (org-beginning-of-line)
31 (org-end-of-line))))))
32
33(provide '+titlecase)
34;;; +titlecase.el ends here
diff --git a/lisp/acdw-defaults.el b/lisp/acdw-defaults.el deleted file mode 100644 index e4c9e14..0000000 --- a/lisp/acdw-defaults.el +++ /dev/null
@@ -1,295 +0,0 @@
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(deftheme use-package)
108(enable-theme 'use-package)
109
110;;; Internal packages
111
112(when (require 'abbrev nil t)
113 (custom-theme-set-variables 'use-package
114 '(abbrev-file-name (sync/ "abbrev.el"))
115 '(save-abbrevs 'silently)))
116
117(when (require 'autorevert nil t)
118 (custom-theme-set-variables 'use-package
119 '(auto-revert-verbose nil)
120 '(global-auto-revert-non-file-buffers t))
121 (global-auto-revert-mode +1))
122
123(when (require 'comp nil t)
124 (custom-theme-set-variables 'use-package
125 '(native-comp-async-report-warnings-errors 'silent)
126 '(native-comp-deferred-compilation t)))
127
128(when (require 'custom nil t)
129 (custom-theme-set-variables 'use-package
130 '(custom-file (etc/ "custom.el"))))
131
132(when (require 'ediff nil t)
133 (custom-theme-set-variables 'use-package
134 '(ediff-window-setup-function #'ediff-setup-windows-plain)))
135
136(when (require 'eldoc nil t)
137 (custom-theme-set-variables 'use-package
138 '(eldoc-echo-area-use-multiline-p nil)
139 '(eldoc-idle-delay 0.1)))
140
141(when (require 'executable nil t)
142 (custom-theme-set-variables 'use-package
143 '(executable-prefix-env t)))
144
145(when (require 'files nil t)
146 (custom-theme-set-variables 'use-package
147 '(auto-save-default nil)
148 '(auto-save-interval 1)
149 '(auto-save-no-message t)
150 '(auto-save-timeout 1)
151 '(auto-save-visited-interval 1)
152 '(backup-by-copying t)
153 '(create-lockfiles nil)
154 '(delete-old-versions t)
155 '(find-file-visit-truename t)
156 '(kept-new-versions 8)
157 '(kept-old-versions 8)
158 '(mode-require-final-newline t)
159 '(version-control t)
160 '(view-read-only t))
161 (dolist (h/f
162 '((after-save-hook . executable-make-buffer-file-executable-if-script-p)
163 (find-file-not-found-functions . create-missing-directories)
164 (find-file-hook . +vc-off@remote)))
165 (add-hook (car h/f) (cdr h/f)))
166 (auto-save-visited-mode))
167
168(when (require 'frame nil t)
169 (custom-theme-set-variables 'use-package
170 '(blink-cursor-blinks 1)
171 '(blink-cursor-interval 0.25)
172 '(blink-cursor-delay 0.25))
173 (blink-cursor-mode))
174
175(when (require 'goto-addr nil t)
176 (if (fboundp 'global-goto-address-mode)
177 (global-goto-address-mode +1)
178 (add-hook 'after-change-major-mode-hook 'goto-address-mode)))
179
180(when (require 'ibuffer nil t)
181 (global-set-key (kbd "C-x C-b") #'ibuffer)
182 (add-hook 'ibuffer-mode-hook #'hl-line-mode))
183
184(when (require 'image nil t)
185 (custom-theme-set-variables 'use-package
186 '(image-use-external-converter
187 (seq-some #'executable-find '("convert" "gm" "ffmpeg")))))
188
189(when (require 'imenu nil t)
190 (custom-theme-set-variables 'use-package
191 '(imenu-auto-rescan t)))
192
193(when (require 'isearch nil t)
194 (custom-theme-set-variables 'use-package
195 '(regexp-search-ring-max default-ring-max)
196 '(search-ring-max default-ring-max)))
197
198(when (require 'minibuffer nil t)
199 (custom-theme-set-variables 'use-package
200 '(completion-category-defaults nil)
201 '(completion-category-overrides '((file (styles partial-completion))))
202 '(completion-ignore-case t)
203 '(completion-styles '(substring partial-completion))
204 '(enable-recursive-minibuffers t)
205 '(file-name-shadow-properties '(invisible t intangible t))
206 '(minibuffer-eldef-shorten-default t)
207 '(minibuffer-prompt-properties '( read-only t
208 cursor-intangible t
209 face minibuffer-prompt))
210 '(read-buffer-completion-ignore-case t))
211 (file-name-shadow-mode)
212 (minibuffer-electric-default-mode))
213
214(when (require 'mouse nil t)
215 (custom-theme-set-variables 'use-package
216 '(mouse-drag-copy-region t)
217 '(mouse-wheel-progressive-speed nil)
218 '(mouse-yank-at-point t)))
219
220(when (require 'paren nil t)
221 (custom-theme-set-variables 'use-package
222 '(show-paren-delay 0.01)
223 '(show-paren-style 'parenthesis)
224 '(show-paren-when-point-in-periphery t)
225 '(show-paren-when-point-inside-paren t))
226 (show-paren-mode)
227 (electric-pair-mode))
228
229(when (require 'recentf nil t)
230 (custom-theme-set-variables 'use-package
231 '(recentf-save-file (var/ "recentf.el"))
232 '(recentf-max-menu-items default-ring-max)
233 '(recentf-max-saved-items nil)
234 '(recentf-auto-cleanup 'mode))
235 (add-to-list 'recentf-exclude etc/)
236 (add-to-list 'recentf-exclude var/)
237 (add-to-list 'recentf-exclude cache/)
238 (add-to-list 'recentf-exclude "-autoloads.el\\'")
239 (recentf-mode +1))
240
241(when (require 'savehist nil t)
242 (custom-theme-set-variables 'use-package
243 '(history-length 1024)
244 '(history-delete-duplicates t)
245 '(savehist-file (var/ "savehist.el"))
246 '(savehist-save-minibuffer-history t)
247 '(savehist-autosave-interval 30)
248 ;; Other variables --- don't truncate any of these.
249 ;; `add-to-history' uses the values of these variables unless
250 ;; they're nil, in which case it falls back to `history-length'.
251 '(kill-ring-max default-ring-max)
252 '(mark-ring-max default-ring-max)
253 '(global-mark-ring-max default-ring-max)
254 '(regexp-search-ring-max default-ring-max)
255 '(search-ring-max default-ring-max)
256 '(kmacro-ring-max default-ring-max)
257 '(eww-history-limit default-ring-max))
258 (dolist (var '(global-mark-ring
259 mark-ring
260 kill-ring
261 kmacro-ring
262 regexp-search-ring
263 search-ring))
264 (add-to-list 'savehist-additional-variables var))
265 (savehist-mode +1))
266
267(when (require 'saveplace nil t)
268 (custom-theme-set-variables 'use-package
269 '(save-place-file (var/ "places.el"))
270 '(save-place-forget-unreadable-files (eq system-type 'gnu/linux)))
271 (save-place-mode 1))
272
273(when (require 'uniquify nil t)
274 (custom-theme-set-variables 'use-package
275 '(uniquify-after-kill-buffer-p t)
276 '(uniquify-buffer-name-style 'forward)
277 '(uniquify-ignore-buffers-re "^\\*")
278 '(uniquify-separator path-separator)))
279
280(when (require 'vc nil t)
281 (custom-theme-set-variables 'use-package
282 '(vc-follow-symlinks t)
283 '(vc-make-backup-files t)))
284
285(when (require 'window nil t)
286 (custom-theme-set-variables 'use-package
287 '(recenter-positions '(top 2 middle bottom))))
288
289;;; New features
290
291(when (fboundp 'pixel-scroll-precision-mode)
292 (pixel-scroll-precision-mode))
293
294(provide 'acdw-defaults)
295;;; acdw-defaults.el ends here
diff --git a/lisp/acdw-funs.el b/lisp/acdw-funs.el deleted file mode 100644 index ed41a61..0000000 --- a/lisp/acdw-funs.el +++ /dev/null
@@ -1,262 +0,0 @@
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.
10See 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.
17See 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.
24See 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.
45If OBJECT is already a list, return OBJECT itself. If it's
46not 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.
53Each 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
56function will `require' them too---but not error if they don't
57exist."
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.
66This 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'.
83That is, with a positive N, deletes newlines as well, leaving -N
84spaces. If N is negative, it will not delete newlines and leave
85N 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.
91If 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.
99When 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.
107A paragraph is defined as continguous non-empty lines of text
108surrounded by empty lines, so opening a paragraph means to make
109three blank lines, then place the point on the second one.
110
111Called 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.
133A paragraph is defined as continguous non-empty lines of text
134surrounded by empty lines, so opening a paragraph means to make
135three blank lines, then place the point on the second one.
136
137Called 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.
170Returns the new, commented, string.
171
172If 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.
191Both FUNC and PREDICATE will be executed with no arguments and in
192the context of each buffer.
193
194If 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.
203FUNC will be executed with no arguments and in the context of
204each 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.
211Each of STRINGS can be a bare string or a list. Strings are
212passed through as-is, but lists are passed to FUNC first as
213arguments. Finally, all the resulting strings are `mapconcat'-ed
214together.
215
216As a special case, if `:separator' is the first of STRINGS, the
217string following will be used as a separator. Otherwise, a
218newline 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.
233If `:separator' is the first of STRINGS, the next string will be used to
234separate the rest of STRINGS."
235 (++concat #'concat strings))
236
237(defun format-concat (&rest strings)
238 "Concatenate formatted STRINGS.
239Each of STRINGS can be a bare string or a list. Bare strings are passed as-is
240to `mapconcat' for concatenation and separation. Lists, however, are passed to
241`format' first.
242
243If `:separator' is the first of STRINGS, the next string will be
244used 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 deleted file mode 100644 index e2258fa..0000000 --- a/lisp/acdw-macs.el +++ /dev/null
@@ -1,293 +0,0 @@
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.
18PREREQS can be a feature, a number, `t', or a list of those.
19
20Features are used as arguments to `eval-after-load'. Numbers are
21used as arguments to `run-with-idle-timer'. `t' will ensure BODY
22runs after Emacs's init time.
23
24When given a list of PREREQS, `eval-after' will nest each one
25from 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.
73DOCSTRING is applied to the variable; its default is DIRECTORY's
74path."
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.
92If MAPS is nil or t, bind to `current-global-map'. Otherwise,
93bind each of BINDINGS to the map or list of maps provided.
94
95BINDINGS is a `setq'-style list of pairs of keys and definitions.
96The key part of each binding can be a string, in which case it's
97passed to `kbd', or a vector or anything else `define-key'
98accepts in the KEY position. The definition part, likewise, can
99be any form `define-key' accepts in that position, with this
100addition: if the form is a `defun' form, it will be defined
101before 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.
151NAME and ARGS are passed to the generated `defun' form.
152Each 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.
194Each of FNS can be an atom (function name) or a list of the
195form (FUNCTION ARGS), where ARGS is a plist. ARGS's possible
196keys are `:doc' (docstring), `:interactive', and `:type', which are
197used as the optional arguments to `autoload'.
198
199You can also pass `:interactive' and `:type' as keyword arguments
200just after FILE, and they'll serve as the default for the
201autoloaded 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.
223If 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.
266TAG, DOC, and ELEMENTS are passed to `tempo-define-template', which see.
267ABBREV, if given, is the abbrev string to use for template expansion
268under 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 deleted file mode 100644 index 30c4f44..0000000 --- a/lisp/acdw.el +++ /dev/null
@@ -1,79 +0,0 @@
1;;; acdw.el --- Basic emacs shit for acdw -*- lexical-binding: t -*-
2
3;;; Code:
4
5(require 'acdw-funs) ; Extra functions
6(require 'acdw-macs) ; Extra macros
7
8(defdir etc/ (locate-user-emacs-file "etc")
9 "Directory for package configuration files.
10See `no-littering' for examples.")
11
12(defdir var/ etc/
13 "Directory for package data file.
14See `no-littering' for examples.")
15
16(defdir cache/ (if-let ((xdg-cache (getenv "XDG_CACHE_HOME")))
17 (expand-file-name "emacs/" xdg-cache)
18 etc/)
19 "Directory for cache files.")
20
21(setq native-compile-target-directory (cache/ "eln" t))
22(when (fboundp 'startup-redirect-eln-cache)
23 (startup-redirect-eln-cache (cache/ "eln" t)))
24
25(defdir sync/ (expand-file-name "/home/case/Sync")
26 "My Syncthing directory.")
27
28(defdir private/ (sync/ "emacs/private"))
29(add-to-list 'load-path private/)
30
31(require 'acdw-defaults) ; Sane defaults
32(require '_acdw) ; Private stuff
33(require '+lisp) ; Lispy goodness
34
35(setc enable-recursive-minibuffers t
36 completions-detailed t
37 completion-ignore-case t
38 read-buffer-completion-ignore-case t
39 read-file-name-completion-ignore-case t
40 initial-buffer-choice #'+initial-buffer
41 initial-scratch-message
42 (format "%s\n\n"
43 (comment-lines
44 (shell-command-to-string "fortune")
45 ";; "))
46 sentence-end-double-space nil
47 save-silently t)
48
49(defkeys t
50 "M-o" #'other-window|switch-buffer
51 "C-x 0" #'delete-window|bury-buffer
52 "C-M-;" #'+lisp-comment-or-uncomment-sexp
53 "M-SPC" #'+cycle-spacing
54 "C-x C-k" #'kill-this-buffer)
55
56(defkeys t
57 "M-u" #'universal-argument)
58
59(defkeys universal-argument-map
60 "M-u" #'universal-argument-more)
61
62(define-advice switch-to-buffer (:after (&rest _) normal-mode)
63 "Automatically determine the mode for created non-file buffers."
64 (when-let ((_ (and (eq major-mode 'fundamental-mode)))
65 (buffer-file-name (buffer-name)))
66 (normal-mode)))
67
68(define-advice canonically-space-region
69 (:around (orig &rest args) double-space-sentences)
70 (let ((sentence-end-double-space t))
71 (apply orig args)))
72
73(with-region-or-buffer indent-region)
74
75(winner-mode)
76
77(provide 'acdw)
78
79;;; acdw.el ends here
diff --git a/lisp/graveyard.el b/lisp/graveyard.el deleted file mode 100644 index 89a776d..0000000 --- a/lisp/graveyard.el +++ /dev/null
@@ -1,50 +0,0 @@
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 deleted file mode 100644 index d2d5e77..0000000 --- a/lisp/init-org.el +++ /dev/null
@@ -1,144 +0,0 @@
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/upload-junk.el b/lisp/upload-junk.el deleted file mode 100644 index 5a9da84..0000000 --- a/lisp/upload-junk.el +++ /dev/null
@@ -1,47 +0,0 @@
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 deleted file mode 100644 index ec84f56..0000000 --- a/lisp/yoke.el +++ /dev/null
@@ -1,392 +0,0 @@
1;;; yoke.el --- Yoke configuration into your config -*- lexical-binding: t; -*-
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/>.
23
24;;; Commentary:
25
26;; THIS IS A WORK IN PROGRESS. DON'T USE IT.
27
28;;; Code:
29
30(require 'cl-lib)
31(require 'package-vc)
32
33;;; User options
34
35(defgroup yoke nil
36 "Customizations for `yoke'."
37 :group 'convenience
38 :prefix "yoke-")
39
40(defcustom yoke-directory package-user-dir
41 "Where to put yoked packages."
42 :type 'file)
43
44(defcustom yoke-cache-directory (locate-user-emacs-file "yoke-cache"
45 "~/.yoke-cache")
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.
51If 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.
68PACKAGE is either a symbol, in which case `yoke' expands to
69basically a named `progn' (good for grouping configuration), or a
70list of the form (NAME . ARGS), where ARGS can be one of the
71following:
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.
88
89 Other pairs may be valid for a given backend; see that
90 backend's `yoke-install' function for more details.
91
92BODY is executed in a `condition-case' so that errors won't keep
93the rest of Emacs from initializing. BODY can also be prepended
94by the following keyword arguments:
95
96 `:after' (FEATURE...)
97
98 `:require' (FEATURE...)
99
100 `:depends' (PACKAGE-SPEC...)
101
102 `:build' (ACTION...)
103
104 `:unless' (PREDICATE)
105
106 `:when' (PREDICATE)
107
108Other keywords are ignored.
109
110\(fn (PACKAGE [SPEC]) [BODY-ARGS] BODY...)"
111 (declare (indent 1))
112 (let* ((name (or (car-safe package) package))
113 (backend (yoke--pget package :backend))
114 ;; Body keyword arguments
115 (after (plist-get body :after))
116 (depends (plist-get body :depends))
117 (req (plist-get body :require))
118 (buildp (plist-member body :build))
119 (build (plist-get body :build))
120 (whenp (plist-member body :when))
121 (when (if whenp (plist-get body :when) t))
122 (unlessp (plist-member body :unless))
123 (unless (if unlessp (plist-get body :unless) nil))
124 ;; Body
125 (body (let ((b body) r)
126 (while (consp b)
127 (if (keywordp (car b))
128 (setf b (cdr b))
129 (setf r (cons (car b) r)))
130 (setf b (cdr b)))
131 (reverse r)))
132 (esym (make-symbol "yoke-error")))
133 ;; Body modifiers. These are applied in reverse order (that is, the last
134 ;; one will be on the outside).
135 ;; --- Require the current package
136 (when req
137 (setf body
138 (append (let (reqs)
139 (dolist (r (ensure-list req) reqs)
140 (let* ((feat (if (eq r t) name r))
141 (+feat (intern (format "+%s" feat))))
142 (push `(require ',feat) reqs)
143 (push `(require ',+feat nil :noerror) reqs)))
144 (reverse reqs))
145 body)))
146 ;; --- Install the package
147 (when (consp package)
148 (push `(yoke-install ',(car package) ,@(cdr package))
149 body))
150 ;; --- Dependencies
151 (when depends
152 (setf body
153 (append (cl-loop for dep in (ensure-list depends)
154 collect `(or (yoke-install ',@(ensure-list dep))
155 (error "Dependency (%s): %S"
156 ',dep ',package)))
157 body)))
158 ;; --- Load after
159 (when after
160 (setf body `((yoke--eval-after ,(cl-subst name t after) ,@body))))
161 ;; --- Conditional expansion
162 (when (or whenp unlessp)
163 (setf body
164 (append (cond
165 ((and whenp unlessp)
166 `((when (or (not ,when) ,unless)
167 (signal 'yoke-predicate
168 '(:when ,when :unless ,unless)))))
169 (whenp
170 `((unless ,when (signal 'yoke-predicate
171 '(:when ,when)))))
172 (unlessp
173 `((when ,unless (signal 'yoke-predicate
174 '(:unless ,unless))))))
175 body)))
176 ;; Expansion
177 `(condition-case ,esym
178 (cl-letf (((symbol-function 'package--save-selected-packages)
179 #'ignore))
180 ;; Body
181 ,@body)
182 (:success
183 ,(unless (atom package)
184 `(setf (alist-get ',name yoke-selected-packages)
185 (list ,@(cdr-safe package))))
186 ',package)
187 (t ,(if yoke-debug-on-error
188 `(signal (car ,esym) (cdr ,esym))
189 `(message "(yoke) %s: %s" (car ,esym) (cdr ,esym)))))))
190
191;;; Installing packages
192
193(defun yoke-install (name &rest args)
194 "Install package NAME, with ARGS."
195 (let ((custom-file null-device)
196 (inhibit-message (and (not (plist-member args :update))
197 (not debug-on-error)))
198 (messages-buffer-name yoke-message-buffer))
199 (funcall
200 (intern
201 (format "yoke-install-%s"
202 (or (plist-get args :backend)
203 (yoke--guess-backend (plist-get args :url))
204 'package)))
205 name args))
206 (yoke--clean-load-path)
207 ;; Don't return nil
208 t)
209
210(defun yoke-install-package (name args &optional tries)
211 "Install package NAME with ARGS using `package' machinery.
212TRIES is an internal variable."
213 (let ((package-user-dir yoke-directory)
214 (url (plist-get args :url))
215 (update (plist-get args :update))
216 (dirname (expand-file-name (format "%s" name)
217 yoke-directory))
218 (tries (or tries 0))
219 load-dir autoloads-file-name)
220 (unless (file-exists-p dirname)
221 (setq dirname (or (car-safe (file-expand-wildcards
222 (concat dirname "*")))
223 dirname)))
224 (setq load-dir
225 (expand-file-name (or (plist-get args :lisp-dir) "") dirname)
226 generated-autoload-file
227 (expand-file-name (format "%s-autoloads.el" name) load-dir))
228 (prog1
229 (condition-case error
230 (cond
231 ;; -- Commented on 2022-12-21
232 ;; ((and (file-exists-p dirname)
233 ;; (not update))
234 ;; (add-to-list 'load-path
235 ;; (expand-file-name
236 ;; (or (plist-get args :lisp-dir) "")
237 ;; dirname)
238 ;; nil #'equal)
239 ;; (require (intern (format "%s-autoloads" name))))
240 ((and url update)
241 (package-vc-update (cadr (assoc name package-alist))))
242 (update
243 (package-update name))
244 (url
245 ;; I'm going to be honest here, this is extremely cursed. But I
246 ;; don't want to get asked about installing the packages, and when
247 ;; the user answers 'no', the function errors. So.. this.
248 (cl-letf (((symbol-function 'yes-or-no-p) #'ignore))
249 (ignore-errors (package-vc-install (cons name args)))))
250 (:else
251 (package-install name)))
252 (file-error (if (> tries 1)
253 (error "(yoke) Can't install `%s'" name)
254 (package-refresh-contents)
255 (yoke-install-package name args (1+ tries)))))
256 (add-to-list 'load-path load-dir nil #'equal)
257 (loaddefs-generate load-dir generated-autoload-file)
258 ;; Do it again, if it doesn't actually /generate/ anything
259 (when (eq 'provide
260 (with-current-buffer (find-file-noselect generated-autoload-file)
261 (read (buffer-substring (point-min) (point-max)))))
262 (loaddefs-generate load-dir generated-autoload-file nil nil nil
263 :generate-full))
264 (load generated-autoload-file :noerror)
265 (kill-buffer (get-file-buffer generated-autoload-file))
266 (package-activate name))))
267
268(defun yoke-install-http (name args)
269 "Install a package NAME using ARGS from an http source."
270 (let* ((url (plist-get args :url))
271 (cached (expand-file-name (file-name-nondirectory url)
272 yoke-cache-directory))
273 (update (plist-get args :update)))
274 (unless url
275 (error "No URL for HTTP download: %S" (cons name args)))
276 (when (or (not (file-exists-p cached))
277 update)
278 (make-directory yoke-cache-directory :parents)
279 (message "Downloading `%s'..." url)
280 (let* ((url-debug t)
281 (buf (url-retrieve-synchronously url)))
282 (with-current-buffer buf
283 (goto-char (point-min))
284 (delete-region (point) (1+ (re-search-forward "^$")))
285 (write-file cached 1)
286 (message "Downloading `%s'...Done." url))))
287 (package-install-file cached)))
288
289(defun yoke-install-file (name args)
290 "Install package NAME using ARGS from a file on-disk."
291 (let ((url (plist-get args :url))
292 (update (plist-get args :update))
293 (dirname (expand-file-name (format "%s" name) yoke-directory)))
294 (if (file-exists-p url)
295 ;; This takes care of updating too.
296 (package-install-file url)
297 (error "(yoke) No such file: `%s'" url))))
298
299;;; Other package transactions
300
301(defun yoke--choose-package ()
302 "Choose a package from `yoke-selected-packages'."
303 (assoc (intern (completing-read "Package: " yoke-selected-packages))
304 yoke-selected-packages))
305
306(defun yoke-update (name &rest args)
307 (interactive (yoke--choose-package))
308 (save-window-excursion
309 (apply #'yoke-install name (append '(:update t)
310 args))))
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.
335If 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.
344If 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)))
358
359(defun yoke--eval-after-init (fn)
360 "Evaluate FN after inititation, or now if Emacs is initialized.
361FN is called with no arguments."
362 (if after-init-time
363 (funcall fn)
364 (add-hook 'after-init-hook fn)))
365
366(defmacro yoke--eval-after (prereqs &rest body)
367 "Evaluate body after PREREQS.
368PREREQS can be a feature, a number, `:init', or a list of those.
369
370Features are used as arguments to `eval-after-load'. Numbers are
371used as arguments to `run-with-idle-timer'. `:init' will ensure BODY
372runs after Emacs's init time.
373
374When given a list of PREREQS, `eval-after' will nest each one
375from left to right."
376 (declare (indent 1) (debug (form def-body)))
377 (setf prereqs (ensure-list prereqs))
378 (if (null prereqs)
379 (macroexp-progn body)
380 (let* ((this (car prereqs))
381 (form `((lambda () (yoke--eval-after ,(cdr prereqs) ,@body)))))
382 (cond
383 ((eq this :init)
384 (append '(yoke--eval-after-init) form))
385 ((numberp this)
386 (append `(run-with-idle-timer ,this nil) form))
387 ((symbolp this)
388 (append `(eval-after-load ',this) form))
389 (:else (user-error "Eval-after: Bad prereq: %S" this))))))
390
391(provide 'yoke)
392;;; yoke.el ends here