about summary refs log tree commit diff stats
path: root/lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp')
-rw-r--r--lisp/+emacs.el18
-rw-r--r--lisp/+flyspell-correct.el4
-rw-r--r--lisp/+ispell.el97
-rw-r--r--lisp/+org-capture.el12
-rw-r--r--lisp/+org.el167
-rw-r--r--lisp/+tempo.el44
-rw-r--r--lisp/+window.el130
-rw-r--r--lisp/acdw.el113
-rw-r--r--lisp/pita.el64
-rw-r--r--lisp/scule.el61
-rw-r--r--lisp/yoke.el72
11 files changed, 727 insertions, 55 deletions
diff --git a/lisp/+emacs.el b/lisp/+emacs.el index 6f40cf0..8817c19 100644 --- a/lisp/+emacs.el +++ b/lisp/+emacs.el
@@ -229,7 +229,7 @@ Do this only if the buffer is not visiting a file."
229 (< (- (time-convert nil 'integer) +save-some-buffers-debounce-time) 229 (< (- (time-convert nil 'integer) +save-some-buffers-debounce-time)
230 +save-some-buffers-debounce-timeout)) 230 +save-some-buffers-debounce-timeout))
231 (save-some-buffers t) 231 (save-some-buffers t)
232 (setq +save-some-buffers-debounce-time (time-convert nil 'integer)))) 232 (setf +save-some-buffers-debounce-time (time-convert nil 'integer))))
233 233
234 234
235;;; Better-default functions ... 235;;; Better-default functions ...
@@ -304,6 +304,11 @@ ARG is passed to `backward-kill-word'."
304;; (advice-add #'yank :after #'+yank@indent) 304;; (advice-add #'yank :after #'+yank@indent)
305;; (advice-add #'yank-pop :after #'+yank@indent) 305;; (advice-add #'yank-pop :after #'+yank@indent)
306 306
307;; https://old.reddit.com/r/emacs/comments/y92y4b/tramp_users_slowness_got_you_down_check/it3a35r/
308(defun +vc-off-when-remote ()
309 (when (file-remote-p (buffer-file-name))
310 (setq-local vc-handled-backends nil)))
311
307 312
308;;; Extra functions 313;;; Extra functions
309 314
@@ -317,7 +322,7 @@ It returns nil with remote files and those without attached files."
317(defun +goto-matching-paren (&optional arg) 322(defun +goto-matching-paren (&optional arg)
318 "Go to the matching paren, similar to vi's %." 323 "Go to the matching paren, similar to vi's %."
319 (interactive "p") 324 (interactive "p")
320 (or arg (setq arg 1)) 325 (or arg (setf arg 1))
321 (cond 326 (cond
322 ;; Check for "outside of bracket" positions 327 ;; Check for "outside of bracket" positions
323 ((looking-at "[\[\(\{]") (forward-sexp arg)) 328 ((looking-at "[\[\(\{]") (forward-sexp arg))
@@ -338,6 +343,15 @@ If the current window is the only window, bury the buffer."
338 343
339;;; Required libraries 344;;; Required libraries
340 345
346(when (require 'abbrev nil :noerror)
347 (setq-default abbrev-file-name (sync/ "abbrev.el")
348 save-abbrevs 'silent))
349
350(when (require 'autorevert nil :noerror)
351 (setq-default global-auto-revert-non-file-buffers t
352 auto-revert-verbose nil)
353 (global-auto-revert-mode +1))
354
341(when (require 'uniquify nil :noerror) 355(when (require 'uniquify nil :noerror)
342 (setq-default uniquify-buffer-name-style 'forward 356 (setq-default uniquify-buffer-name-style 'forward
343 uniquify-separator path-separator 357 uniquify-separator path-separator
diff --git a/lisp/+flyspell-correct.el b/lisp/+flyspell-correct.el index f4fc956..9a33cc0 100644 --- a/lisp/+flyspell-correct.el +++ b/lisp/+flyspell-correct.el
@@ -12,8 +12,8 @@ With PREFIX, prompt to change the current dictionary."
12 (when prefix 12 (when prefix
13 (let ((current-prefix-arg nil)) 13 (let ((current-prefix-arg nil))
14 (call-interactively #'ispell-change-dictionary))) 14 (call-interactively #'ispell-change-dictionary)))
15 (+with-message "Checking spelling" 15 (with-message "Checking spelling"
16 (flyspell-correct-move (point-min) :forward :rapid))) 16 (flyspell-correct-move (point-min) :forward :rapid)))
17 17
18(defun +flyspell-correct-buffer-h (&rest _) 18(defun +flyspell-correct-buffer-h (&rest _)
19 "Run `+flyspell-correct-buffer'. 19 "Run `+flyspell-correct-buffer'.
diff --git a/lisp/+ispell.el b/lisp/+ispell.el new file mode 100644 index 0000000..10c31b8 --- /dev/null +++ b/lisp/+ispell.el
@@ -0,0 +1,97 @@
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/+org-capture.el b/lisp/+org-capture.el index 7ed4e00..06dfcfd 100644 --- a/lisp/+org-capture.el +++ b/lisp/+org-capture.el
@@ -17,7 +17,7 @@ LIST defaults to `org-capture-templates'."
17;; Set it up as a generic value. Based on the one for `alist-get'. 17;; Set it up as a generic value. Based on the one for `alist-get'.
18(gv-define-expander +org-capture--get 18(gv-define-expander +org-capture--get
19 (lambda (do key &optional alist) 19 (lambda (do key &optional alist)
20 (setq alist (or alist org-capture-templates)) 20 (setf alist (or alist org-capture-templates))
21 (macroexp-let2 macroexp-copyable-p k key 21 (macroexp-let2 macroexp-copyable-p k key
22 (gv-letplace (getter setter) alist 22 (gv-letplace (getter setter) alist
23 (macroexp-let2 nil p `(assoc ,k ,getter 'equal) 23 (macroexp-let2 nil p `(assoc ,k ,getter 'equal)
@@ -27,7 +27,7 @@ LIST defaults to `org-capture-templates'."
27 (let ((set-exp 27 (let ((set-exp
28 `(if ,p (setcdr ,p ,v) 28 `(if ,p (setcdr ,p ,v)
29 ,(funcall setter 29 ,(funcall setter
30 `(cons (setq ,p (cons ,k ,v)) 30 `(cons (setf ,p (cons ,k ,v))
31 ,getter))))) 31 ,getter)))))
32 `(progn 32 `(progn
33 ,set-exp 33 ,set-exp
@@ -36,7 +36,7 @@ LIST defaults to `org-capture-templates'."
36(defun +org-capture-sort (&optional list) 36(defun +org-capture-sort (&optional list)
37 "Sort LIST by string keys. 37 "Sort LIST by string keys.
38LIST is a symbol and defaults to `org-capture-templates'." 38LIST is a symbol and defaults to `org-capture-templates'."
39 (setq list (or list 'org-capture-templates)) 39 (setf list (or list 'org-capture-templates))
40 (set list (sort (symbol-value list) (lambda (a b) 40 (set list (sort (symbol-value list) (lambda (a b)
41 (string< (car a) (car b)))))) 41 (string< (car a) (car b))))))
42 42
@@ -68,9 +68,9 @@ SORT-AFTER, when set to t, will call
68properly process the variable." 68properly process the variable."
69 ;; LIST defaults to `org-capture-templates' 69 ;; LIST defaults to `org-capture-templates'
70 (declare (indent 2)) 70 (declare (indent 2))
71 (unless list (setq list 'org-capture-templates)) 71 (unless list (setf list 'org-capture-templates))
72 ;; Ensure VALUE is a list to cons properly 72 ;; Ensure VALUE is a list to cons properly
73 (unless (listp value) (setq value (list value))) 73 (unless (listp value) (setf value (list value)))
74 (when (> (length key) 1) 74 (when (> (length key) 1)
75 ;; Check for existence of groups. 75 ;; Check for existence of groups.
76 (let ((expected (cl-loop for i from 1 to (1- (length key)) 76 (let ((expected (cl-loop for i from 1 to (1- (length key))
@@ -87,7 +87,7 @@ properly process the variable."
87 87
88(defun +org-template--ensure-path (keys &optional list) 88(defun +org-template--ensure-path (keys &optional list)
89 "Ensure path of keys exists in `org-capture-templates'." 89 "Ensure path of keys exists in `org-capture-templates'."
90 (unless list (setq list 'org-capture-templates)) 90 (unless list (setf list 'org-capture-templates))
91 (when (> (length key) 1) 91 (when (> (length key) 1)
92 ;; Check for existence of groups. 92 ;; Check for existence of groups.
93 (let ((expected (cl-loop for i from 1 to (1- (length key)) 93 (let ((expected (cl-loop for i from 1 to (1- (length key))
diff --git a/lisp/+org.el b/lisp/+org.el index b17a1fa..70962d6 100644 --- a/lisp/+org.el +++ b/lisp/+org.el
@@ -1,5 +1,106 @@
1;;; +org.el --- -*- lexical-binding: t -*- 1;;; +org.el --- -*- lexical-binding: t -*-
2 2
3;;; Org Return DWIM
4;; [[https://github.com/alphapapa/unpackaged.el][unpackaged]] and [[http://kitchingroup.cheme.cmu.edu/blog/2017/04/09/A-better-return-in-org-mode/][kitchin]]
5
6(defun +org-element-descendant-of (type element)
7 "Return non-nil if ELEMENT is a descendant of TYPE.
8TYPE should be an element type, like `item' or `paragraph'.
9ELEMENT should be a list like that returned by `org-element-context'."
10 ;; MAYBE: Use `org-element-lineage'.
11 (when-let* ((parent (org-element-property :parent element)))
12 (or (eq type (car parent))
13 (+org-element-descendant-of type parent))))
14
15(defun +org-return-dwim (&optional prefix)
16 "A helpful replacement for `org-return'.
17With PREFIX, call `org-return'."
18 (interactive "P")
19 ;; Auto-fill if enabled
20 (when auto-fill-function
21 (dolist (func (ensure-list auto-fill-function))
22 (funcall func)))
23 (cond
24 (prefix ; Handle prefix
25 (pcase prefix
26 ('(4) (newline))
27 ('(16) (newline 2))
28 (_ (newline prefix))))
29 ((and org-return-follows-link ; Open link
30 (eq 'link (car (org-element-context))))
31 (org-open-at-point-global))
32 ((org-at-heading-p) ; Open a line after a heading
33 (let ((heading-start (org-entry-beginning-position)))
34 (goto-char (org-entry-end-position))
35 (cond ((and (org-at-heading-p)
36 (= heading-start (org-entry-beginning-position)))
37 ;; Entry ends on its heading, so add 2 newlines
38 (end-of-line)
39 (newline 2))
40 (t
41 ;; Entry ends after its heading, so back up
42 (forward-line -1)
43 (end-of-line)
44 (when (org-at-heading-p)
45 (forward-line)
46 (newline)
47 (forward-line -1))
48 (while (not (looking-back (rx (repeat 3 (seq (optional blank) "\n")))
49 nil))
50 (newline))
51 (forward-line -1)))))
52 ((org-at-item-checkbox-p) ; Insert a new checkbox item
53 (end-of-line)
54 (org-insert-todo-heading nil))
55 ((org-in-item-p) ; Insert a new list item
56 (let* ((context (org-element-context))
57 (first-item-p (eq 'plain-list (car context)))
58 (itemp (eq 'item (car context)))
59 (emptyp (or
60 ;; This (regular) list item is empty
61 (eq (org-element-property :contents-begin context)
62 (org-element-property :contents-end context))
63 ;; This (definition) list item is empty
64 (looking-at " *::")))
65 (item-child-p (+org-element-descendant-of 'item context)))
66 (cond ((and itemp emptyp)
67 (delete-region (line-beginning-position) (line-end-position))
68 (newline))
69 ((or first-item-p
70 (and itemp (not emptyp))
71 item-child-p)
72 (org-end-of-item)
73 (org-insert-item))
74 (t
75 (delete-region (line-beginning-position) (line-end-position))
76 (newline)))))
77 ((and (fboundp 'org-inlinetask-in-task-p) ; Don't insert a new heading with
78 (org-inlinetask-in-task-p)) ; inline tasks
79 (org-return))
80 ((org-at-table-p) ; Insert a new org-table row
81 (cond ((save-excursion
82 (beginning-of-line)
83 (cl-loop with end = (line-end-position)
84 for cell = (org-element-table-cell-parser)
85 always (equal (org-element-property :contents-begin cell)
86 (org-element-property :contents-end cell))
87 while (re-search-forward "|" end t)))
88 ;; Empty row: end the table
89 (delete-region (line-beginning-position) (line-end-position))
90 (org-return))
91 (t
92 ;; Non-empty row
93 (org-return))))
94 (t ; Otherwise---just call `org-return'.
95 (org-return))))
96
97(defun +org-table-copy-down|+org-return (&optional n)
98 "Call `org-table-copy-down' or `+org-return' depending on context."
99 (interactive "P")
100 (if (org-table-check-inside-data-field 'noerror)
101 (org-table-copy-down (or n 1))
102 (+org-return-dwim n)))
103
3;;; Copy org trees as HTML 104;;; Copy org trees as HTML
4 105
5;; Thanks to Oleh Krehel, via [[https://emacs.stackexchange.com/questions/54292/copy-results-of-org-export-directly-to-clipboard][this StackExchange question]]. 106;; Thanks to Oleh Krehel, via [[https://emacs.stackexchange.com/questions/54292/copy-results-of-org-export-directly-to-clipboard][this StackExchange question]].
@@ -41,4 +142,70 @@ and POST-PROCESS are passed to `org-export-to-file'."
41 ("—" "---")))) 142 ("—" "---"))))
42 (replace-match replace nil nil))))) 143 (replace-match replace nil nil)))))
43 144
145;;; A ... different ... `org-open-at-point-dwim'
146;; I honestly don't remember what the difference is between this and the
147;; O.G. one is.. hopefully this one fixes annoying stupid problems.
148
149(defun +org-open-at-point-dwim (&optional arg)
150 "Open thing at point, or if there isn't something, list things."
151 (interactive "P")
152 (save-excursion
153 (let* ((this-char-type (org-element-type (org-element-context)))
154 (prev-char-type (ignore-errors
155 (save-excursion
156 (backward-char)
157 (org-element-type (org-element-context)))))
158 (types '(citation citation-reference clock comment comment-block
159 footnote-definition footnote-reference headline
160 inline-src-block inlinetask keyword link
161 node-property planning src-block timestamp))
162 (type this-char-type))
163 (when (and (memq this-char-type types) (memq prev-char-type types))
164 (backward-char)
165 (setq type prev-char-type)) ; what the fuckckckckck
166 ;; Okay, so this ^ is pretty janky and doesn't /really/ work that well,
167 ;; especially on DEADLINE (and probably SCHEDULED) lines. However, since
168 ;; I really just want to open the list of URLs /most of the time/, I'm
169 ;; fixing it like this instead.
170 (unless (and (memq type types)
171 (ignore-errors (org-open-at-point arg)
172 t))
173 (while (not
174 (progn
175 (org-back-to-heading)
176 (car (org-offer-links-in-entry (current-buffer) (point) 1))))
177 (org-up-heading-all 1))
178 (org-open-at-point arg)))))
179
180;;; Skip invisible shit when moving around
181(defun +org-ignore-invisible (fn &rest r)
182 ":around ADVICE to ignore invisible text in `org-mode' buffers."
183 ;; TODO: generalize to all modes
184 (cond ((and (derived-mode-p #'org-mode)
185 (org-invisible-p))
186 (while (org-invisible-p)
187 (forward-char))
188 (apply fn r))
189 (t (apply fn r))))
190
191;;; Faces
192
193;;; Better org faces
194;; see `org-emphasis-alist'
195
196(defface org-bold '((t (:weight bold)))
197 "Bold face in `org-mode' documents.")
198
199(defface org-italic '((t (:slant italic)))
200 "Italic face in `org-mode' documents.")
201
202(defface org-underline '((t (:underline t)))
203 "Underline face in `org-mode' documents.")
204
205(defface org-strikethrough '((t (:strike-through t)))
206 "Strike-through face for `org-mode' documents.")
207
208;; `org-verbatim' and `org-code' are apparently already things, so we skip them
209;; here.
210
44(provide '+org) 211(provide '+org)
diff --git a/lisp/+tempo.el b/lisp/+tempo.el new file mode 100644 index 0000000..2324665 --- /dev/null +++ b/lisp/+tempo.el
@@ -0,0 +1,44 @@
1;;; +tempo.el --- easier tempo definition -*- lexical-binding: t -*-
2
3(require 'tempo)
4
5;; TODO: I need to figure out where this function goes.
6(defun delete2 (list &rest elems)
7 "Delete each element of ELEMS, and the next item, from LIST."
8 (let ((r nil))
9 (while (consp list)
10 (if (member (car list) elems)
11 (setf list (cdr list))
12 (setf r (cons (car list) r)))
13 (setf list (cdr list)))
14 (reverse r)))
15
16(defmacro define-tempo (tag doc &rest elements)
17 "Define a template and add its tag to MODE's abbrev-table.
18TAG, DOC, and ELEMENTS are passed to `tempo-define-template', which see.
19ABBREV, if given, is the abbrev string to use for template expansion
20under MODE's abbrev-table. If ABBREV isn't given, TAG will be used."
21 (declare (indent 1))
22 (let* ((template (gensym))
23 (tag (cond ((stringp tag) tag)
24 ((symbolp tag) (symbol-name tag))
25 (t (user-error "TAG must be a string or symbol: %S" tag))))
26 (mode (or (plist-get elements :mode) nil))
27 (abbrev (or (plist-get elements :abbrev) tag))
28 (taglist (or (plist-get elements :taglist) nil))
29 (table (let ((tname (and mode (derived-mode-abbrev-table-name mode))))
30 (while (and tname (not (memq tname abbrev-table-name-list)))
31 (setq tname (and (get mode 'derived-mode-parent)
32 (derived-mode-abbrev-table-name
33 (get mode 'derived-mode-parent)))))
34 (or tname 'global-abbrev-table)))
35 (elements (delete2 elements :mode :abbrev :taglist)))
36 `(let ((,template (tempo-define-template ,tag
37 ',elements
38 ,tag
39 ,doc
40 ,taglist)))
41 (define-abbrev ,table ,tag "" ,template :system t)
42 (put ,template 'no-self-insert t))))
43
44(provide '+tempo)
diff --git a/lisp/+window.el b/lisp/+window.el new file mode 100644 index 0000000..52b3712 --- /dev/null +++ b/lisp/+window.el
@@ -0,0 +1,130 @@
1;;; +window.el --- Fixes for Emacs's window.el -*- lexical-binding: t; -*-
2
3;;; Commentary:
4
5;; Do I want to propose this change in the Emacs ML?
6
7;;; Code:
8
9(require 'window)
10
11;;; Split windows based on `window-total-width', not `window-width'
12;; I have to just redefine these functions because the check is really deep in
13;; there.
14
15(defun window-splittable-p (window &optional horizontal)
16 "Return non-nil if `split-window-sensibly' may split WINDOW.
17Optional argument HORIZONTAL nil or omitted means check whether
18`split-window-sensibly' may split WINDOW vertically. HORIZONTAL
19non-nil means check whether WINDOW may be split horizontally.
20
21WINDOW may be split vertically when the following conditions
22hold:
23- `window-size-fixed' is either nil or equals `width' for the
24 buffer of WINDOW.
25- `split-height-threshold' is an integer and WINDOW is at least as
26 high as `split-height-threshold'.
27- When WINDOW is split evenly, the emanating windows are at least
28 `window-min-height' lines tall and can accommodate at least one
29 line plus - if WINDOW has one - a mode line.
30
31WINDOW may be split horizontally when the following conditions
32hold:
33- `window-size-fixed' is either nil or equals `height' for the
34 buffer of WINDOW.
35- `split-width-threshold' is an integer and WINDOW is at least as
36 wide as `split-width-threshold'.
37- When WINDOW is split evenly, the emanating windows are at least
38 `window-min-width' or two (whichever is larger) columns wide."
39 (when (and (window-live-p window)
40 (not (window-parameter window 'window-side)))
41 (with-current-buffer (window-buffer window)
42 (if horizontal
43 ;; A window can be split horizontally when its width is not
44 ;; fixed, it is at least `split-width-threshold' columns wide
45 ;; and at least twice as wide as `window-min-width' and 2 (the
46 ;; latter value is hardcoded).
47 (and (memq window-size-fixed '(nil height))
48 ;; Testing `window-full-width-p' here hardly makes any
49 ;; sense nowadays. This can be done more intuitively by
50 ;; setting up `split-width-threshold' appropriately.
51 (numberp split-width-threshold)
52 (>= (window-total-width window)
53 (max split-width-threshold
54 (* 2 (max window-min-width 2)))))
55 ;; A window can be split vertically when its height is not
56 ;; fixed, it is at least `split-height-threshold' lines high,
57 ;; and it is at least twice as high as `window-min-height' and 2
58 ;; if it has a mode line or 1.
59 (and (memq window-size-fixed '(nil width))
60 (numberp split-height-threshold)
61 (>= (window-height window)
62 (max split-height-threshold
63 (* 2 (max window-min-height
64 (if mode-line-format 2 1))))))))))
65
66(defun split-window-sensibly (&optional window)
67 "Split WINDOW in a way suitable for `display-buffer'.
68WINDOW defaults to the currently selected window.
69If `split-height-threshold' specifies an integer, WINDOW is at
70least `split-height-threshold' lines tall and can be split
71vertically, split WINDOW into two windows one above the other and
72return the lower window. Otherwise, if `split-width-threshold'
73specifies an integer, WINDOW is at least `split-width-threshold'
74columns wide and can be split horizontally, split WINDOW into two
75windows side by side and return the window on the right. If this
76can't be done either and WINDOW is the only window on its frame,
77try to split WINDOW vertically disregarding any value specified
78by `split-height-threshold'. If that succeeds, return the lower
79window. Return nil otherwise.
80
81By default `display-buffer' routines call this function to split
82the largest or least recently used window. To change the default
83customize the option `split-window-preferred-function'.
84
85You can enforce this function to not split WINDOW horizontally,
86by setting (or binding) the variable `split-width-threshold' to
87nil. If, in addition, you set `split-height-threshold' to zero,
88chances increase that this function does split WINDOW vertically.
89
90In order to not split WINDOW vertically, set (or bind) the
91variable `split-height-threshold' to nil. Additionally, you can
92set `split-width-threshold' to zero to make a horizontal split
93more likely to occur.
94
95Have a look at the function `window-splittable-p' if you want to
96know how `split-window-sensibly' determines whether WINDOW can be
97split."
98 (let ((window (or window (selected-window))))
99 (or (and (window-splittable-p window)
100 ;; Split window vertically.
101 (with-selected-window window
102 (split-window-below)))
103 (and (window-splittable-p window t)
104 ;; Split window horizontally.
105 (with-selected-window window
106 (split-window-right)))
107 (and
108 ;; If WINDOW is the only usable window on its frame (it is
109 ;; the only one or, not being the only one, all the other
110 ;; ones are dedicated) and is not the minibuffer window, try
111 ;; to split it vertically disregarding the value of
112 ;; `split-height-threshold'.
113 (let ((frame (window-frame window)))
114 (or
115 (eq window (frame-root-window frame))
116 (catch 'done
117 (walk-window-tree (lambda (w)
118 (unless (or (eq w window)
119 (window-dedicated-p w))
120 (throw 'done nil)))
121 frame nil 'nomini)
122 t)))
123 (not (window-minibuffer-p window))
124 (let ((split-height-threshold 0))
125 (when (window-splittable-p window)
126 (with-selected-window window
127 (split-window-below))))))))
128
129(provide '+window)
130;;; +window.el ends here
diff --git a/lisp/acdw.el b/lisp/acdw.el index 444f249..f039540 100644 --- a/lisp/acdw.el +++ b/lisp/acdw.el
@@ -30,20 +30,20 @@ the filesystem, unless INHIBIT-MKDIR is non-nil."
30 30
31;;; Convenience functions 31;;; Convenience functions
32 32
33(defun define-keys (maps &rest keydefs) 33(defun define-key* (maps &rest keydefs)
34 "Define KEYDEFS in MAPS. 34 "Define KEYDEFS in MAPS.
35Convenience wrapper around `define-key'." 35Convenience wrapper around `define-key'."
36 (unless (zerop (mod (length keydefs) 2)) 36 (unless (zerop (mod (length keydefs) 2))
37 (user-error "Wrong number of arguments: %S" (length keydefs))) 37 (user-error "Wrong number of arguments: %S" (length keydefs)))
38 (dolist (map (if (or (atom maps) (eq (car maps) 'keymap)) 38 (dolist (map (if (or (atom maps) (eq (car maps) 'keymap))
39 (list maps) 39 (list maps)
40 maps)) 40 maps))
41 (cl-loop for (key def) on keydefs by #'cddr 41 (cl-loop for (key def) on keydefs by #'cddr
42 do (let ((key (if (stringp key) (kbd key) key))) 42 do (let ((key (if (stringp key) (kbd key) key)))
43 (define-key (if (symbolp map) 43 (define-key (if (symbolp map)
44 (symbol-value map) 44 (symbol-value map)
45 map) 45 map)
46 key def))))) 46 key def)))))
47 47
48(unless (fboundp 'ensure-list) 48(unless (fboundp 'ensure-list)
49 ;; Just in case we're using an old version of Emacs. 49 ;; Just in case we're using an old version of Emacs.
@@ -57,10 +57,11 @@ not a list, return a one-element list containing OBJECT."
57 57
58(defun add-to-list* (lists &rest things) 58(defun add-to-list* (lists &rest things)
59 "Add THINGS to LISTS. 59 "Add THINGS to LISTS.
60LISTS can be one list variable or a list. 60LISTS can be one list variable or a list. Each thing of THINGS
61Each thing of THINGS can be either a variablel (the thing), or a list of the form 61can be either a variablel (the thing), or a list of the form
62(ELEMENT &optional APPEND COMPARE-FN), which is passed to 62(ELEMENT &optional APPEND COMPARE-FN), which is passed to
63`add-to-list'." 63`add-to-list'."
64 (declare (indent 1))
64 (dolist (l (ensure-list lists)) 65 (dolist (l (ensure-list lists))
65 (dolist (thing things) 66 (dolist (thing things)
66 (apply #'add-to-list l (ensure-list thing))))) 67 (apply #'add-to-list l (ensure-list thing)))))
@@ -69,26 +70,73 @@ Each thing of THINGS can be either a variablel (the thing), or a list of the for
69 "Add FUNCTIONS to HOOKS. 70 "Add FUNCTIONS to HOOKS.
70Each function in FUNCTIONS can be a singleton or a list of the 71Each function in FUNCTIONS can be a singleton or a list of the
71form (FUNCTION &optional DEPTH LOCAL)." 72form (FUNCTION &optional DEPTH LOCAL)."
73 (declare (indent 1))
72 (dolist (hook (ensure-list hooks)) 74 (dolist (hook (ensure-list hooks))
73 (dolist (fn functions) 75 (dolist (fn functions)
74 (apply #'add-hook hook (ensure-list fn))))) 76 (apply #'add-hook hook (ensure-list fn)))))
75 77
78(defun +concat (&rest strings)
79 "Concat STRINGS separated by SEPARATOR.
80SEPARATOR is \"\\n\" unless the keyword argument `:separator' is
81given, followed by the separator to use. Each item in STRINGS is
82either a string or a list or strings, which is concatenated
83without any separator."
84 (let (ret
85 ;; I don't know why a `cl-defun' with
86 ;; (&rest strings &key (separator "\n")) doesn't work
87 (separator (or (cl-loop for i from 0 upto (length strings)
88 if (eq (nth i strings) :separator)
89 return (nth (1+ i) strings))
90 "\n")))
91 (while strings
92 (let ((string (pop strings)))
93 (cond ((eq string :separator) (pop strings))
94 ((listp string) (push (apply #'concat string) ret))
95 ((stringp string) (push string ret)))))
96 (mapconcat #'identity (nreverse ret) separator)))
97
98(defun require* (&rest features)
99 "Require FEATURES in order.
100Each feature of FEATURES can also be a list of the arguments to
101pass to `require', which see."
102 (condition-case e
103 (dolist (feature features)
104 (apply #'require (ensure-list feature)))
105 (:success (mapcar (lambda (f) (car (ensure-list f))) features))
106 (t (signal (car e) (cdr e)))))
107
76;;; Convenience macros 108;;; Convenience macros
77 109
110(defmacro define-local-before-save-hook (mode-or-hook &rest body)
111 "Add a local `before-save-hook' to MODE-OR-HOOK."
112 (declare (indent 1))
113 (let* ((name (format "%s" mode-or-hook))
114 (external-name (intern (format "%s@before-save" name)))
115 (internal-name (intern (format "before-save@%s" name)))
116 (hook (if (string-suffix-p "-hook" name)
117 mode-or-hook
118 (intern (format "%s-hook" name)))))
119 `(progn
120 (defun ,internal-name ()
121 ,@body)
122 (defun ,external-name ()
123 (add-hook 'before-save-hook #',internal-name nil :local))
124 (add-hook ',hook #',external-name))))
125
78(defmacro setq-local-hook (hook &rest args) 126(defmacro setq-local-hook (hook &rest args)
79 "Run `setq-local' on ARGS when running HOOK." 127 "Run `setq-local' on ARGS when running HOOK."
80 (declare (indent 1)) 128 (declare (indent 1))
81 (let ((fn (intern (format "%s-setq-local" hook)))) 129 (let ((fn (intern (format "%s-setq-local" hook))))
82 (when (and (fboundp fn) 130 (when (and (fboundp fn)
83 (functionp fn)) 131 (functionp fn))
84 (setq args (append (function-get fn 'setq-local-hook-settings) args))) 132 (setf args (append (function-get fn 'setq-local-hook-settings) args)))
85 (unless (and (< 0 (length args)) 133 (unless (and (< 0 (length args))
86 (zerop (mod (length args) 2))) 134 (zerop (mod (length args) 2)))
87 (user-error "Wrong number of arguments: %S" (length args))) 135 (user-error "Wrong number of arguments: %S" (length args)))
88 `(progn 136 `(progn
89 (defun ,fn () 137 (defun ,fn ()
90 ,(format "Set local variables after `%s'." hook) 138 ,(format "Set local variables after `%s'." hook)
91 (setq-local ,@args)) 139 (setq-local ,@args))
92 (function-put ',fn 'setq-local-hook-settings ',args) 140 (function-put ',fn 'setq-local-hook-settings ',args)
93 (add-hook ',hook #',fn)))) 141 (add-hook ',hook #',fn))))
94 142
@@ -103,3 +151,38 @@ If body executes without errors, MESSAGE...Done will be displayed."
103 ,@body) 151 ,@body)
104 (:success (message "%s...done" ,msg)) 152 (:success (message "%s...done" ,msg))
105 (t (signal (car e) (cdr e))))))) 153 (t (signal (car e) (cdr e)))))))
154
155;; https://emacs.stackexchange.com/a/39324/37239
156;; XXX: This shit don't work rn
157(defun ignore-invisible-overlays (fn)
158 "Execute FN, ignoring invisible overlays.
159FN should return a point."
160 (let ((overlay nil)
161 (point nil))
162 (setq point (and (funcall fn) (point)))
163 (setq overlay (car (overlays-at (point))))
164 (while (and overlay (member 'invisible (overlay-properties overlay)))
165 (goto-char (overlay-end overlay))
166 (setq point (and (funcall fn) (point)))
167 (setq overlay (car (overlays-at (point)))))
168 point))
169
170;;; Extras
171;; Trying to avoid a whole install of crux ...
172
173(defun kill-and-join-forward (&optional arg)
174 "Kill the line or, if at the end of a line, join with the next.
175This command is `visual-line-mode'-aware. If ARG is provided,
176it's passed on to kill a line, but not to delete indentation.
177When joining, this command deletes whitespace."
178 (interactive "P")
179 (if (and (eolp) (not (bolp)))
180 (delete-indentation 1)
181 (funcall (if visual-line-mode #'kill-visual-line #'kill-line) arg)))
182
183(defun other-window|switch-buffer ()
184 "Call `other-window' or `switch-buffer' depending on windows."
185 (interactive)
186 (if (one-window-p)
187 (switch-to-buffer nil)
188 (other-window 1)))
diff --git a/lisp/pita.el b/lisp/pita.el new file mode 100644 index 0000000..92ebf1b --- /dev/null +++ b/lisp/pita.el
@@ -0,0 +1,64 @@
1;;; pita.el --- wrappers making emacs less of a PITA -*- lexical-binding: t -*-
2;; 🥙
3
4(defmacro with-message (msg &rest body)
5 (declare (indent 1))
6 (when (listp msg)
7 (setq msg (apply #'format (car msg) (cdr msg))))
8 (when (string-match "[[:alnum:]]\\'" msg)
9 (setq msg (concat msg "...")))
10 (let ((m (gensym))
11 (r (gensym)))
12 `(let ((,m ,msg)
13 (,r nil))
14 (condition-case e
15 (setq r (progn (message ,m) ,@body))
16 (:success (message "%s done" ,m) r)
17 (t (signal (car e) (cdr e)))))))
18
19(defun walk-tree-replace (tree find replace)
20 (let ((r nil))
21 (dolist (form tree)
22 (push (cond ((eq find form) replace)
23 ((listp form)
24 (walk-tree-replace form find replace))
25 (t form))
26 r))
27 (reverse r)))
28
29(defmacro with-pr (msg &rest body)
30 (declare (indent 1))
31 (when (listp msg)
32 (setq msg (apply #'format (car msg) (cdr msg))))
33 (when (string-match "[[:alnum:]]\\'" msg)
34 (setq msg (concat msg "...")))
35 (let ((pr (gensym))
36 (m (gensym)))
37 `(let* ((,m ,msg)
38 (,pr (unless (minibufferp)
39 (make-progress-reporter ,m))))
40 ,@(or (and pr (walk-tree-replace body '@ `(progress-reporter-update ,pr)))
41 body)
42 (and ,pr (progress-reporter-done ,pr)))))
43
44
45;;; crux advices
46;; these should all go :before the function they're advising.
47
48(defun with-region-or-buffer (&rest _)
49 (interactive (if mark-active
50 (list (region-beginning) (region-end))
51 (list (point-min) (point-max)))))
52
53(defun with-region-or-line (&rest _)
54 (interactive (if mark-active
55 (list (region-beginning) (region-end))
56 (list (line-beginning-position) (line-end-position)))))
57
58(defun with-region-or-to-eol (&rest _)
59 (interactive (if mark-active
60 (list (region-beginning) (region-end))
61 (list (point) (line-end-position)))))
62
63(provide 'pita)
64;;; pita.el ends here
diff --git a/lisp/scule.el b/lisp/scule.el new file mode 100644 index 0000000..3ed58bb --- /dev/null +++ b/lisp/scule.el
@@ -0,0 +1,61 @@
1;;; scule.el --- -scule twiddling -*- lexical-binding: t; -*-
2
3;; Copyright (C) 2022 Case Duckworth
4
5;; Author: Case Duckworth <case@bob>
6;; Keywords: convenience
7
8;; This program is free software; you can redistribute it and/or modify
9;; it under the terms of the GNU General Public License as published by
10;; the Free Software Foundation, either version 3 of the License, or
11;; (at your option) any later version.
12
13;; This program is distributed in the hope that it will be useful,
14;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16;; GNU General Public License for more details.
17
18;; You should have received a copy of the GNU General Public License
19;; along with this program. If not, see <https://www.gnu.org/licenses/>.
20
21;;; Commentary:
22
23;; DWIM functions for twiddling "scule", or text case (a fancy word for "upper
24;; case" is "magiscule", for example, and "lower case" is "miniscule").
25
26;;; Code:
27
28(require 'thingatpt)
29
30;;; Utility macro
31;;;###autoload
32(defmacro defscule (name &optional region-fn word-fn)
33 (let ((fn-name (intern (format "scule-%s" name)))
34 (region-fn (or region-fn (intern (format "%s-region" name))))
35 (word-fn (or word-fn (intern (format "%s-word" name)))))
36 `(defun ,fn-name (arg)
37 ,(concat (capitalize (symbol-name name)) " words in the region if active, or word at point.\n"
38 "If the region is active, call `" (symbol-name region-fn) "'.\n"
39 "Otherwise, it calls `" (symbol-name word-fn) "' on the word at point and\n"
40 "the following ARG - 1 words.")
41 (interactive "*p")
42 (if (use-region-p)
43 (,region-fn (region-beginning) (region-end) (region-noncontiguous-p))
44 (let ((word-bound (save-excursion
45 (skip-chars-forward "^[:word:]")
46 (bounds-of-thing-at-point 'word))))
47 (when (and (car word-bound) (cdr word-bound))
48 (,region-fn (car word-bound) (cdr word-bound))
49 (goto-char (cdr word-bound))
50 (,word-fn (1- arg))))))))
51
52;;;###autoload
53(progn (defscule upcase)
54 (autoload 'scule-upcase "scule" nil t)
55 (defscule downcase)
56 (autoload 'scule-downcase "scule" nil t)
57 (defscule capitalize)
58 (autoload 'scule-capitalize "scule" nil t))
59
60(provide 'scule)
61;;; scule.el ends here
diff --git a/lisp/yoke.el b/lisp/yoke.el index 4f40869..68b02c4 100644 --- a/lisp/yoke.el +++ b/lisp/yoke.el
@@ -47,20 +47,20 @@ installed to `yoke-dir'."
47 (let ((generated-autoload-file 47 (let ((generated-autoload-file
48 (expand-file-name (format "%s-autoloads.el" pkg) dir)) 48 (expand-file-name (format "%s-autoloads.el" pkg) dir))
49 (backup-inhibited t) 49 (backup-inhibited t)
50 (version-control 'never) 50 (version-control 'never)
51 (message-log-max nil) 51 (message-log-max nil)
52 (inhibit-message t)) 52 (inhibit-message t))
53 (unless (file-exists-p generated-autoload-file) 53 (unless (file-exists-p generated-autoload-file)
54 (let ((find-file-hook nil) 54 (let ((find-file-hook nil)
55 (write-file-functions nil) 55 (write-file-functions nil)
56 (debug-on-error nil) 56 (debug-on-error nil)
57 (left-margin 0)) 57 (left-margin 0))
58 (if (fboundp 'make-directory-autoloads) 58 (if (fboundp 'make-directory-autoloads)
59 (make-directory-autoloads dir generated-autoload-file) 59 (make-directory-autoloads dir generated-autoload-file)
60 (and (fboundp 'update-directory-autoloads) 60 (and (fboundp 'update-directory-autoloads)
61 (update-directory-autoloads dir))))) 61 (update-directory-autoloads dir)))))
62 (when-let ((buf (find-buffer-visiting generated-autoload-file))) 62 (when-let ((buf (find-buffer-visiting generated-autoload-file)))
63 (kill-buffer buf)) 63 (kill-buffer buf))
64 (load generated-autoload-file :noerror :nomessage))) 64 (load generated-autoload-file :noerror :nomessage)))
65 (t (user-error "Directory \"%s\" doesn't exist." dir))) 65 (t (user-error "Directory \"%s\" doesn't exist." dir)))
66 dir)) 66 dir))
@@ -83,13 +83,13 @@ Similar-ish to `plist-get', but works on non-proper plists."
83 ,g)))) 83 ,g))))
84 84
85(defun delete2 (list &rest elems) 85(defun delete2 (list &rest elems)
86 "Delete ELEM and the next item from LIST." 86 "Delete each element of ELEMS, and the next item, from LIST."
87 (let ((r nil)) 87 (let ((r nil))
88 (while (consp list) 88 (while (consp list)
89 (if (member (car list) elems) 89 (if (member (car list) elems)
90 (setq list (cdr list)) 90 (setf list (cdr list))
91 (setq r (cons (car list) r))) 91 (setf r (cons (car list) r)))
92 (setq list (cdr list))) 92 (setf list (cdr list)))
93 (reverse r))) 93 (reverse r)))
94 94
95(defun eval-after-init (fn) 95(defun eval-after-init (fn)
@@ -105,17 +105,17 @@ FEATURES can be an atom or a list; as an atom it works like
105`with-eval-after-load'. The special feature `init' will evaluate 105`with-eval-after-load'. The special feature `init' will evaluate
106BODY after Emacs is finished initializing." 106BODY after Emacs is finished initializing."
107 (declare (indent 1) 107 (declare (indent 1)
108 (debug (form def-body))) 108 (debug (form def-body)))
109 (if (eq features 'init) 109 (if (eq features 'init)
110 `(eval-after-init (lambda () ,@body)) 110 `(eval-after-init (lambda () ,@body))
111 (unless (listp features) 111 (unless (listp features)
112 (setq features (list features))) 112 (setf features (list features)))
113 (if (null features) 113 (if (null features)
114 (macroexp-progn body) 114 (macroexp-progn body)
115 (let* ((this (car features)) 115 (let* ((this (car features))
116 (rest (cdr features))) 116 (rest (cdr features)))
117 `(with-eval-after-load ',this 117 `(with-eval-after-load ',this
118 (eval-after ,rest ,@body)))))) 118 (eval-after ,rest ,@body))))))
119 119
120(defun yoke-pkg-name (pkg) 120(defun yoke-pkg-name (pkg)
121 (intern (format "yoke:%s" pkg))) 121 (intern (format "yoke:%s" pkg)))
@@ -131,7 +131,7 @@ BODY after Emacs is finished initializing."
131 (unless nil unlessp) ; :unless PREDICATE 131 (unless nil unlessp) ; :unless PREDICATE
132 &allow-other-keys) 132 &allow-other-keys)
133 "Yoke a PKG into your Emacs session." 133 "Yoke a PKG into your Emacs session."
134 (declare (indent defun)) 134 (declare (indent 2))
135 (let ((name (yoke-pkg-name pkg)) 135 (let ((name (yoke-pkg-name pkg))
136 (body (delete2 body 136 (body (delete2 body
137 :depends :when :unless :after :load))) 137 :depends :when :unless :after :load)))
@@ -141,11 +141,11 @@ BODY after Emacs is finished initializing."
141 (*yoke-repo* ,repo) 141 (*yoke-repo* ,repo)
142 (*yoke-dest* ,(when repo `(yoke-repo-dir ',pkg ,repo)))) 142 (*yoke-dest* ,(when repo `(yoke-repo-dir ',pkg ,repo))))
143 ,@(cond 143 ,@(cond
144 ((and whenp unlessp) 144 ((and whenp unlessp)
145 `((when (or (not ,when) ,unless) 145 `((when (or (not ,when) ,unless)
146 (cl-return-from ,name nil)))) 146 (cl-return-from ,name nil))))
147 (whenp `((unless ,when (cl-return-from ,name nil)))) 147 (whenp `((unless ,when (cl-return-from ,name nil))))
148 (unlessp `((when ,unless (cl-return-from ,name nil))))) 148 (unlessp `((when ,unless (cl-return-from ,name nil)))))
149 ,@(cl-loop for (pkg* repo* load-path*) in depends 149 ,@(cl-loop for (pkg* repo* load-path*) in depends
150 collect `(or (yoke-lasso ',pkg* ,repo* ,load-path*) 150 collect `(or (yoke-lasso ',pkg* ,repo* ,load-path*)
151 (cl-return-from ,name nil))) 151 (cl-return-from ,name nil)))
@@ -157,3 +157,15 @@ BODY after Emacs is finished initializing."
157 body)) 157 body))
158 (:success ',pkg) 158 (:success ',pkg)
159 (t (message "%s: %s" ',name e)))))) 159 (t (message "%s: %s" ',name e))))))
160
161;;; Extras
162
163(defun yoke-imenu-insinuate ()
164 "Insinuate `yoke' forms for `imenu'."
165 (require 'imenu)
166 (setf (alist-get "Yoke" imenu-generic-expression nil nil #'equal)
167 (list (rx (: "(yoke" (+ space)
168 (group (+ (not space)))
169 (+ space)
170 (group (+ (not space)))))
171 1)))