diff options
author | Case Duckworth | 2023-01-03 23:02:26 -0600 |
---|---|---|
committer | Case Duckworth | 2023-01-03 23:02:26 -0600 |
commit | 259363fd4f21d796c3c6a35be6398aed3f493a73 (patch) | |
tree | f2b782a37fa93b4b5be918bbe97c2c62aefd00d0 /lisp | |
parent | meh (diff) | |
download | emacs-259363fd4f21d796c3c6a35be6398aed3f493a73.tar.gz emacs-259363fd4f21d796c3c6a35be6398aed3f493a73.zip |
bleh
Diffstat (limited to 'lisp')
-rw-r--r-- | lisp/+emacs.el | 6 | ||||
-rw-r--r-- | lisp/+org.el | 56 | ||||
-rw-r--r-- | lisp/acdw.el | 35 | ||||
-rw-r--r-- | lisp/dawn.el | 67 | ||||
-rw-r--r-- | lisp/def.el | 142 | ||||
-rw-r--r-- | lisp/org-word-count.el | 297 | ||||
-rw-r--r-- | lisp/yoke.el | 111 |
7 files changed, 636 insertions, 78 deletions
diff --git a/lisp/+emacs.el b/lisp/+emacs.el index 870e4e2..97377a3 100644 --- a/lisp/+emacs.el +++ b/lisp/+emacs.el | |||
@@ -55,7 +55,7 @@ Do this only if the buffer is not visiting a file." | |||
55 | cursor-type 'bar | 55 | cursor-type 'bar |
56 | custom-file (.etc "custom.el") | 56 | custom-file (.etc "custom.el") |
57 | delete-old-versions t | 57 | delete-old-versions t |
58 | echo-keystrokes 0.1 | 58 | echo-keystrokces 0.1 |
59 | ediff-window-setup-function 'ediff-setup-windows-plain | 59 | ediff-window-setup-function 'ediff-setup-windows-plain |
60 | eldoc-echo-area-use-multiline-p nil | 60 | eldoc-echo-area-use-multiline-p nil |
61 | eldoc-idle-delay 0.1 | 61 | eldoc-idle-delay 0.1 |
@@ -103,7 +103,7 @@ Do this only if the buffer is not visiting a file." | |||
103 | ;; 'command-completion-default-include-p) | 103 | ;; 'command-completion-default-include-p) |
104 | ;; 'command-completion-default-include-p) | 104 | ;; 'command-completion-default-include-p) |
105 | read-process-output-max 1048576 ; We’re in the future man. Set that to at least a megabyte | 105 | read-process-output-max 1048576 ; We’re in the future man. Set that to at least a megabyte |
106 | recenter-positions '(top middle bottom) | 106 | recenter-positions '(top 2 middle bottom) |
107 | regexp-search-ring-max 100 | 107 | regexp-search-ring-max 100 |
108 | regexp-search-ring-max 200 | 108 | regexp-search-ring-max 200 |
109 | save-interprogram-paste-before-kill t | 109 | save-interprogram-paste-before-kill t |
@@ -239,7 +239,7 @@ spaces. If N is negative, it will not delete newlines and leave | |||
239 | N spaces. See docstring of `cycle-spacing' for the meaning of | 239 | N spaces. See docstring of `cycle-spacing' for the meaning of |
240 | PRESERVE-NL-BACK and MODE." | 240 | PRESERVE-NL-BACK and MODE." |
241 | (interactive "*p") | 241 | (interactive "*p") |
242 | (cycle-spacing (- n) preserve-nl-back mode)) | 242 | (cycle-spacing (- n))) |
243 | 243 | ||
244 | (defun +save-buffers-quit (&optional arg) | 244 | (defun +save-buffers-quit (&optional arg) |
245 | "Silently save each buffer, then kill the current connection. | 245 | "Silently save each buffer, then kill the current connection. |
diff --git a/lisp/+org.el b/lisp/+org.el index 70962d6..7698ec9 100644 --- a/lisp/+org.el +++ b/lisp/+org.el | |||
@@ -208,4 +208,60 @@ and POST-PROCESS are passed to `org-export-to-file'." | |||
208 | ;; `org-verbatim' and `org-code' are apparently already things, so we skip them | 208 | ;; `org-verbatim' and `org-code' are apparently already things, so we skip them |
209 | ;; here. | 209 | ;; here. |
210 | 210 | ||
211 | ;;; Inhibit hooks on `org-agenda' | ||
212 | ;; It's really annoying when I call `org-agenda' and five hundred Ispell | ||
213 | ;; processes are created because I have `flyspell-mode' in the hook. This mode | ||
214 | ;; inhibits those hooks when entering the agenda, but runs them when opening the | ||
215 | ;; actual buffer. | ||
216 | |||
217 | (defun +org-agenda-inhibit-hooks (fn &rest r) | ||
218 | "Advice to inhibit hooks when entering `org-agenda'." | ||
219 | (let ((org-mode-hook nil)) | ||
220 | (apply fn r))) | ||
221 | |||
222 | (defvar-local +org-hook-has-run-p nil | ||
223 | "Whether `org-mode-hook' has run in the current buffer.") | ||
224 | |||
225 | (defun +org-agenda-switch-run-hooks (&rest _) | ||
226 | "Advice to run `org-mode-hook' when entering org-mode. | ||
227 | This should only fire when switching to a buffer from `org-agenda'." | ||
228 | (unless +org-hook-has-run-p | ||
229 | (run-hooks 'org-mode-hook) | ||
230 | (setq +org-hook-has-run-p t))) | ||
231 | |||
232 | (define-minor-mode +org-agenda-inhibit-hooks-mode | ||
233 | "Inhibit `org-mode-hook' when opening `org-agenda'." | ||
234 | :lighter " A/h" | ||
235 | :global t | ||
236 | (cond (+org-agenda-inhibit-hooks-mode | ||
237 | (advice-add 'org-agenda :around #'+org-agenda-inhibit-hooks) | ||
238 | (advice-add 'org-agenda-switch-to :after #'+org-agenda-switch-run-hooks)) | ||
239 | (:else | ||
240 | (advice-remove 'org-agenda #'+org-agenda-inhibit-hooks) | ||
241 | (advice-remove 'org-agenda-switch-to #'+org-agenda-switch-run-hooks)))) | ||
242 | |||
243 | ;;; Drawers | ||
244 | (defun +org-hide-drawers-except-point () | ||
245 | "Hide all drawers except for the one point is in." | ||
246 | ;; Most of this bit is taken from `org-fold--hide-drawers'. | ||
247 | (let ((pt (point)) | ||
248 | (begin (point-min)) | ||
249 | (end (point-max))) | ||
250 | (save-excursion | ||
251 | (goto-char begin) | ||
252 | (while (and (< (point) end) | ||
253 | (re-search-forward org-drawer-regexp end t)) | ||
254 | (if (org-fold-folded-p nil 'drawer) | ||
255 | (goto-char (org-fold-next-folding-state-change 'drawer nil end)) | ||
256 | (let* ((drawer (org-element-at-point)) | ||
257 | (type (org-element-type drawer)) | ||
258 | (el-begin (org-element-property :begin drawer)) | ||
259 | (el-end (org-element-property :end drawer))) | ||
260 | (when (memq type '(drawer property-drawer)) | ||
261 | (org-fold-hide-drawer-toggle | ||
262 | (if (< el-begin pt el-end) 'off 'on) | ||
263 | nil drawer) | ||
264 | (goto-char el-end)))))))) | ||
265 | |||
266 | |||
211 | (provide '+org) | 267 | (provide '+org) |
diff --git a/lisp/acdw.el b/lisp/acdw.el index 75e1755..a9ef893 100644 --- a/lisp/acdw.el +++ b/lisp/acdw.el | |||
@@ -1,6 +1,8 @@ | |||
1 | ;;; acdw.el -- bits and bobs -*- lexical-binding: t; -*- | 1 | ;;; acdw.el -- bits and bobs -*- lexical-binding: t; -*- |
2 | ;; by C. Duckworth <acdw@acdw.net> | 2 | ;; by C. Duckworth <acdw@acdw.net> |
3 | (require 'cl-lib) | 3 | (require 'cl-lib) |
4 | ;; def.el is here | ||
5 | (require 'def) | ||
4 | 6 | ||
5 | ;;; Define both a directory and a function expanding to a file in that directory | 7 | ;;; Define both a directory and a function expanding to a file in that directory |
6 | 8 | ||
@@ -197,6 +199,22 @@ If body executes without errors, MESSAGE...Done will be displayed." | |||
197 | `(let* ((,this ,(car clauses))) | 199 | `(let* ((,this ,(car clauses))) |
198 | (if ,this ,this (either ,@(cdr clauses))))))) | 200 | (if ,this ,this (either ,@(cdr clauses))))))) |
199 | 201 | ||
202 | (defun mapc-buffers (fn &optional pred) | ||
203 | "Perform FN on buffers matching PRED. | ||
204 | If PRED is nil or absent, perform FN on all buffers. Both FN and | ||
205 | PRED are called within a `with-current-buffer' form and without | ||
206 | arguments." | ||
207 | (let ((pred (cond | ||
208 | ((listp pred) | ||
209 | (lambda () (apply #'derived-mode-p pred))) | ||
210 | ((functionp pred) pred) | ||
211 | ((null pred) (lambda () t)) | ||
212 | (:else (user-error "Bad predicate"))))) | ||
213 | (dolist (buf (buffer-list)) | ||
214 | (with-current-buffer buf | ||
215 | (when (funcall pred) | ||
216 | (funcall fn)))))) | ||
217 | |||
200 | ;; https://emacs.stackexchange.com/a/39324/37239 | 218 | ;; https://emacs.stackexchange.com/a/39324/37239 |
201 | ;; XXX: This shit don't work rn | 219 | ;; XXX: This shit don't work rn |
202 | (defun ignore-invisible-overlays (fn) | 220 | (defun ignore-invisible-overlays (fn) |
@@ -233,5 +251,22 @@ When called with prefix ARG, unconditionally switch buffer." | |||
233 | (switch-to-buffer (other-buffer) nil t) | 251 | (switch-to-buffer (other-buffer) nil t) |
234 | (other-window 1))) | 252 | (other-window 1))) |
235 | 253 | ||
254 | ;;; Set variables more better-er | ||
255 | ;; Now this doesn't do `setf'-style stuff. | ||
256 | |||
257 | (defmacro setc (&rest args) | ||
258 | "Customize user options using ARGS like `setq'." | ||
259 | (declare (debug setq)) | ||
260 | (unless (zerop (mod (length args) 2)) | ||
261 | (user-error "Dangling argument: %S" var)) | ||
262 | (let (form) | ||
263 | (while args | ||
264 | (push `(customize-set-variable | ||
265 | ',(pop args) | ||
266 | ,(pop args) | ||
267 | "Set by `setc'.") | ||
268 | form)) | ||
269 | `(progn ,@(nreverse form)))) | ||
270 | |||
236 | (provide 'acdw) | 271 | (provide 'acdw) |
237 | ;;; acdw.el ends here | 272 | ;;; acdw.el ends here |
diff --git a/lisp/dawn.el b/lisp/dawn.el index 806c422..30aab7c 100644 --- a/lisp/dawn.el +++ b/lisp/dawn.el | |||
@@ -1,4 +1,13 @@ | |||
1 | ;;; dawn.el --- Do things at dawn (and dusk) -*- lexical-binding: t; -*- | 1 | ;;; dawn.el --- Lightweight dawn/dusk task scheduling -*- lexical-binding: t; -*- |
2 | |||
3 | ;; Copyright (C) 2022 Case Duckworth | ||
4 | |||
5 | ;; Author: Case Duckworth | ||
6 | ;; Maintainer: Case Duckworth <acdw@acdw.net> | ||
7 | ;; URL: https://codeberg.org/acdw/dusk.el | ||
8 | ;; Version: 0.3.0 | ||
9 | ;; Keywords: calendar, themes, convenience | ||
10 | ;; Package-Requires: ((emacs "24.3")) | ||
2 | 11 | ||
3 | ;;; Commentary: | 12 | ;;; Commentary: |
4 | 13 | ||
@@ -12,6 +21,8 @@ | |||
12 | (require 'cl-lib) | 21 | (require 'cl-lib) |
13 | (require 'solar) | 22 | (require 'solar) |
14 | 23 | ||
24 | ;;; Timers | ||
25 | |||
15 | (defvar dawn--dawn-timer nil | 26 | (defvar dawn--dawn-timer nil |
16 | "Timer for dawn-command.") | 27 | "Timer for dawn-command.") |
17 | 28 | ||
@@ -21,16 +32,19 @@ | |||
21 | (defvar dawn--reset-timer nil | 32 | (defvar dawn--reset-timer nil |
22 | "Timer to reset dawn at midnight.") | 33 | "Timer to reset dawn at midnight.") |
23 | 34 | ||
35 | ;;; Functions | ||
36 | |||
24 | (defun dawn-encode-time (f) | 37 | (defun dawn-encode-time (f) |
25 | "Encode fractional time F." | 38 | "Encode fractional time F. |
26 | (let ((hhmm (cl-floor f)) | 39 | If F is nil, return nil." |
27 | (date (cdddr (decode-time)))) | 40 | (when f |
28 | (encode-time | 41 | (let ((hhmm (cl-floor f)) |
29 | (append (list 0 | 42 | (date (cdddr (decode-time)))) |
30 | (round (* 60 (cadr hhmm))) | 43 | (encode-time |
31 | (car hhmm) | 44 | (append (list 0 |
32 | ) | 45 | (round (* 60 (cadr hhmm))) |
33 | date)))) | 46 | (car hhmm)) |
47 | date))))) | ||
34 | 48 | ||
35 | (defun dawn-midnight () | 49 | (defun dawn-midnight () |
36 | "Return the time of the /next/ midnight." | 50 | "Return the time of the /next/ midnight." |
@@ -46,22 +60,34 @@ | |||
46 | "Return the time of today's sunset." | 60 | "Return the time of today's sunset." |
47 | (dawn-encode-time (caadr (solar-sunrise-sunset (calendar-current-date))))) | 61 | (dawn-encode-time (caadr (solar-sunrise-sunset (calendar-current-date))))) |
48 | 62 | ||
63 | ;;; Interface | ||
64 | |||
65 | ;;;###autoload | ||
49 | (defun dawn-schedule (dawn-command dusk-command) | 66 | (defun dawn-schedule (dawn-command dusk-command) |
50 | "Run DAWN-COMMAND at sunrise, and DUSK-COMMAND at dusk. | 67 | "Run DAWN-COMMAND at sunrise, and DUSK-COMMAND at dusk. |
51 | RESET is an argument for internal use." | 68 | Requires `calendar-longitude' and `calendar-latitude' to be set; |
69 | if they're not, it will prompt the user for them or error." | ||
52 | (when (or (null calendar-longitude) | 70 | (when (or (null calendar-longitude) |
53 | (null calendar-latitude)) | 71 | (null calendar-latitude)) |
54 | (user-error "`dawn' won't work without setting %s!" | 72 | (or (solar-setup) |
55 | (cond ((and (null calendar-longitude) | 73 | (user-error "`dawn' won't work without setting %s!" |
56 | (null calendar-latitude)) | 74 | (cond ((and (null calendar-longitude) |
57 | "`calendar-longitude' and `calendar-latitude'") | 75 | (null calendar-latitude)) |
58 | ((null calendar-longitude) | 76 | "`calendar-longitude' and `calendar-latitude'") |
59 | "`calendar-longitude'") | 77 | ((null calendar-longitude) |
60 | ((null calendar-latitude) | 78 | "`calendar-longitude'") |
61 | "`calendar-latitude'")))) | 79 | ((null calendar-latitude) |
80 | "`calendar-latitude'"))))) | ||
62 | (let ((dawn (dawn-sunrise)) | 81 | (let ((dawn (dawn-sunrise)) |
63 | (dusk (dawn-sunset))) | 82 | (dusk (dawn-sunset))) |
64 | (cond | 83 | (cond |
84 | ((or (null dawn) (null dusk)) | ||
85 | ;; There is no sunrise or sunset, due to how close we are to the poles. | ||
86 | ;; In this case, we must figure out whether it's day or night. | ||
87 | (pcase (caddr (solar-sunrise-sunset (calendar-current-date))) | ||
88 | ("0:00" (funcall dusk-command)) ; 0 hours of daylight | ||
89 | ("24:00" (funcall dawn-command)) ; 24 hours of daylight | ||
90 | )) | ||
65 | ((time-less-p nil dawn) | 91 | ((time-less-p nil dawn) |
66 | ;; If it isn't dawn yet, it's still dark. Run DUSK-COMMAND and schedule | 92 | ;; If it isn't dawn yet, it's still dark. Run DUSK-COMMAND and schedule |
67 | ;; DAWN-COMMAND and DUSK-COMMAND for later. | 93 | ;; DAWN-COMMAND and DUSK-COMMAND for later. |
@@ -76,7 +102,6 @@ RESET is an argument for internal use." | |||
76 | (t ;; Otherwise, it's past dusk, so run DUSK-COMMAND. | 102 | (t ;; Otherwise, it's past dusk, so run DUSK-COMMAND. |
77 | (funcall dusk-command))) | 103 | (funcall dusk-command))) |
78 | ;; Schedule a reset at midnight, to re-calculate dawn/dusk times. | 104 | ;; Schedule a reset at midnight, to re-calculate dawn/dusk times. |
79 | ;(unless reset) | ||
80 | (run-at-time (dawn-midnight) nil | 105 | (run-at-time (dawn-midnight) nil |
81 | #'dawn-schedule dawn-command dusk-command))) | 106 | #'dawn-schedule dawn-command dusk-command))) |
82 | 107 | ||
diff --git a/lisp/def.el b/lisp/def.el new file mode 100644 index 0000000..0bf91b2 --- /dev/null +++ b/lisp/def.el | |||
@@ -0,0 +1,142 @@ | |||
1 | ;;; def.el --- defining macros -*- lexical-binding: t; -*- | ||
2 | |||
3 | ;;; Code: | ||
4 | |||
5 | (require 'cl-lib) | ||
6 | |||
7 | ;;; Utility | ||
8 | |||
9 | (defun def--assert-args (pred args &optional error-type &rest error-args) | ||
10 | "Assert that ARGS follows PRED. | ||
11 | If it doesn't, raise an error. ERROR-TYPE will be the type of | ||
12 | that error (defaults to `user-error'), and it and ERROR-ARGS are | ||
13 | passed in a list to `signal'." | ||
14 | (unless (funcall pred args) | ||
15 | (funcall #'signal | ||
16 | (or error-type 'user-error) | ||
17 | (or error-args | ||
18 | (list "Wrong arguments" args))))) | ||
19 | |||
20 | (defmacro o (&rest fns) | ||
21 | "Compose FNS into a new function for one argument." | ||
22 | (if (null fns) | ||
23 | `(lambda (&rest args) args) | ||
24 | `(lambda (&rest args) | ||
25 | (apply | ||
26 | #',(car fns) | ||
27 | (ensure-list (apply (o ,@(cdr fns)) args)))))) | ||
28 | |||
29 | ;; TODO: I need to figure out where this function goes. | ||
30 | (defun def--delete2 (list &rest elems) | ||
31 | "Delete each element of ELEMS, and the next item, from LIST." | ||
32 | (let ((r nil)) | ||
33 | (while (consp list) | ||
34 | (if (member (car list) elems) | ||
35 | (setf list (cdr list)) | ||
36 | (setf r (cons (car list) r))) | ||
37 | (setf list (cdr list))) | ||
38 | (reverse r))) | ||
39 | |||
40 | ;;; Keybindings | ||
41 | |||
42 | (defmacro defkeys (maps &rest bindings) | ||
43 | "Define key BINDINGS in MAPS. | ||
44 | If MAPS is nil or t, bind to `current-global-map'. Otherwise, | ||
45 | bind each of BINDINGS to the map or list of maps provided. | ||
46 | |||
47 | BINDINGS is a `setq'-style list of pairs of keys and definitions. | ||
48 | The key part of each binding can be a string, in which case it's | ||
49 | passed to `kbd', or a vector or anything else `define-key' | ||
50 | accepts in the KEY position. The definition part, likewise, can | ||
51 | be any form `define-key' accepts in that position, with this | ||
52 | addition: if the form is a `defun' form, it will be defined | ||
53 | before any keys are bound." | ||
54 | (declare (indent 1)) | ||
55 | (def--assert-args (o cl-evenp length) bindings | ||
56 | 'wrong-number-of-arguments 'defkeys 'evenp (length bindings)) | ||
57 | `(progn | ||
58 | ,@(cl-loop | ||
59 | for map in (ensure-list maps) | ||
60 | for first-map-p = t then nil | ||
61 | append | ||
62 | (cl-loop | ||
63 | for (keys def) on bindings by #'cddr | ||
64 | for defp = (memq (car-safe def) '(defmap defun defmacro)) | ||
65 | if (and defp first-map-p) collect def into defuns | ||
66 | append | ||
67 | (cl-loop | ||
68 | for key in (ensure-list keys) | ||
69 | collect (list 'define-key | ||
70 | (if (memq map '(t nil)) | ||
71 | '(current-global-map) | ||
72 | (or (car-safe map) map)) | ||
73 | (if (stringp key) | ||
74 | `(kbd ,key) | ||
75 | key) | ||
76 | (if defp | ||
77 | (cl-case (car def) | ||
78 | ((defmap) (cadr def)) | ||
79 | ((defun defmacro) `#',(cadr def)) | ||
80 | (otherwise (error "Bad def type: %S" | ||
81 | (car def)))) | ||
82 | def))) | ||
83 | into keydefs | ||
84 | finally return | ||
85 | (let ((all (append defuns keydefs))) | ||
86 | (if-let ((after (plist-get (cdr-safe map) :after))) | ||
87 | `((eval-after ,after | ||
88 | ,@all)) | ||
89 | all)))))) | ||
90 | |||
91 | (defmacro defmap (name docstring &rest bindings) | ||
92 | "Define a keymap named NAME, with BINDINGS." | ||
93 | (declare (indent 1) (doc-string 2)) | ||
94 | `(,(if (boundp name) 'setq 'defvar) ,name | ||
95 | ;;; ^ probably a terrible hack | ||
96 | (let ((map (make-sparse-keymap))) | ||
97 | (defkeys map ,@bindings) | ||
98 | map) | ||
99 | ,@(unless (boundp name) (list docstring)))) | ||
100 | |||
101 | ;;; Hooks | ||
102 | |||
103 | (defmacro defhook (hooks &rest body) | ||
104 | "Define a function to hook into HOOKS. | ||
105 | NAME and ARGS are passed to the generated `defun' form. | ||
106 | Each hook in HOOKS can be the name of a hook or a list of the form | ||
107 | (HOOK DEPTH LOCAL), where each argument is the same as in | ||
108 | `add-hook'." | ||
109 | (declare (indent 1)) | ||
110 | (let* ((name (or (plist-get body :name) | ||
111 | (intern (format "%s/h" | ||
112 | (mapconcat | ||
113 | (lambda (h) | ||
114 | (string-remove-suffix | ||
115 | "-hook" (symbol-name (or (car-safe h) | ||
116 | h)))) | ||
117 | (ensure-list hooks) | ||
118 | "|"))))) | ||
119 | (args (or (plist-get body :args) nil)) | ||
120 | (doc (or (plist-get body :doc) nil)) | ||
121 | (forms ; (DEFUN . FUNCS) | ||
122 | (cl-loop for form in (def--delete2 body :name :args :doc) | ||
123 | if (eq (car form) 'function) | ||
124 | collect form into funcs | ||
125 | else collect form into defuns | ||
126 | finally return (cons defuns funcs))) | ||
127 | (defun-forms (car forms)) | ||
128 | (func-forms (cdr forms))) | ||
129 | `(progn | ||
130 | ,@(when defun-forms | ||
131 | `((defun ,name ,args ,@(when doc (list doc)) ,@defun-forms))) | ||
132 | ,@(cl-loop for hook in (ensure-list hooks) | ||
133 | for h = (or (car-safe hook) hook) | ||
134 | for ha = (cdr-safe hook) | ||
135 | if defun-forms | ||
136 | collect `(add-hook ',h #',name ,@ha) | ||
137 | append | ||
138 | (cl-loop for fn in func-forms | ||
139 | collect `(add-hook ',h ,fn ,@ha)))))) | ||
140 | |||
141 | (provide 'def) | ||
142 | ;;; def.el ends here | ||
diff --git a/lisp/org-word-count.el b/lisp/org-word-count.el new file mode 100644 index 0000000..d6d2598 --- /dev/null +++ b/lisp/org-word-count.el | |||
@@ -0,0 +1,297 @@ | |||
1 | ;;; org-word-count.el --- org-word-count in the modeline -*- lexical-binding: t; -*- | ||
2 | |||
3 | ;;; Commentary: | ||
4 | |||
5 | ;;; Code: | ||
6 | |||
7 | (require 'org) | ||
8 | (require 'cl-lib) | ||
9 | |||
10 | (defgroup org-word-count nil | ||
11 | "Extra fast word-counting in `org-mode'." | ||
12 | :group 'org) | ||
13 | |||
14 | (defvar-local org-word-count-word-count nil | ||
15 | "Running total of words in this buffer.") | ||
16 | |||
17 | (defvar-local org-word-count-string nil | ||
18 | "String for the modeline.") | ||
19 | |||
20 | (defcustom org-word-count-format "%sw " | ||
21 | "Format for org word count in modeline." | ||
22 | :type 'string) | ||
23 | |||
24 | (defcustom org-word-count-huge-string "huge" | ||
25 | "String to display with a huge buffer." | ||
26 | :type 'string) | ||
27 | |||
28 | (defcustom org-word-count-update-after-funcs '(org-narrow-to-subtree | ||
29 | org-narrow-to-block | ||
30 | org-narrow-to-element | ||
31 | org-capture-narrow) | ||
32 | "Functions after which to update the word count." | ||
33 | :type '(repeat function)) | ||
34 | |||
35 | (defcustom org-word-count-deletion-idle-timer 0.25 | ||
36 | "Length of time, in seconds, to wait before updating word-count." | ||
37 | :type 'number) | ||
38 | |||
39 | (defcustom org-word-count-huge-change 5000 | ||
40 | "Number of characters that constitute a \"huge\" insertion." | ||
41 | :type 'number) | ||
42 | |||
43 | (defcustom org-word-count-huge-buffer 10000 | ||
44 | "Number of words past which we're not going to try to count." | ||
45 | :type 'number) | ||
46 | |||
47 | (defvar org-word-count-correction -5 | ||
48 | "Number to add to `org-word-count-word-count', for some reason? | ||
49 | `org-word-count-word-count' seems to consistently be off by 5. Thus | ||
50 | this correction. (At some point I should correct the underlying | ||
51 | code... probably).") | ||
52 | |||
53 | (defvar-local org-word-count-update-timer nil) | ||
54 | |||
55 | ;;; Variables from org-wc | ||
56 | |||
57 | (defun org-word-count-list-of-strings-p (arg) | ||
58 | (cl-every #'stringp arg)) | ||
59 | |||
60 | (defun org-word-count--downcase-list-of-strings-set-default (var val) | ||
61 | (set-default var (mapcar #'downcase val))) | ||
62 | |||
63 | (defcustom org-word-count-ignored-tags '("nowc" "noexport" "ARCHIVE") | ||
64 | "List of tags for which subtrees will be ignored in word counts" | ||
65 | :type '(repeat string) | ||
66 | :safe #'org-word-count-list-of-strings-p) | ||
67 | |||
68 | (defcustom org-word-count-ignore-commented-trees t | ||
69 | "Ignore trees with COMMENT-prefix if non-nil." | ||
70 | :type 'boolean | ||
71 | :safe #'booleanp) | ||
72 | |||
73 | (defcustom org-word-count-default-link-count 'description-or-path | ||
74 | "Default way of counting words in links. | ||
75 | This is applied to any link type not specified in any of | ||
76 | ‘org-word-count-ignored-link-types’,‘org-word-count-one-word-link-types’, or | ||
77 | ‘org-word-count-only-description-link-types’ " | ||
78 | :type '(choice | ||
79 | (const :tag "Count words in description or else path part of links" description-or-path) | ||
80 | (const :tag "Count words only in description part of links" description) | ||
81 | (const :tag "Count links as 0 words" ignore) | ||
82 | (const :tag "Count links as 1 word" oneword) | ||
83 | (const :tag "Count words only in path part of links" path)) | ||
84 | :safe 'symbolp) | ||
85 | |||
86 | (defcustom org-word-count-ignored-link-types nil | ||
87 | "Link types which won't be counted as a word" | ||
88 | :type '(repeat string) | ||
89 | :safe #'org-word-count-list-of-strings-p) | ||
90 | |||
91 | (defcustom org-word-count-one-word-link-types '("zotero") | ||
92 | "Link types which will be counted as one word" | ||
93 | :type '(repeat string) | ||
94 | :safe #'org-word-count-list-of-strings-p) | ||
95 | |||
96 | (defcustom org-word-count-description-or-path-link-types '() | ||
97 | "Link types for which the description or the path should be counted" | ||
98 | :type '(repeat string) | ||
99 | :safe #'org-word-count-list-of-strings-p) | ||
100 | |||
101 | (defcustom org-word-count-only-description-link-types '("note") | ||
102 | "Link types for which only the description should be counted" | ||
103 | :type '(repeat string) | ||
104 | :safe #'org-word-count-list-of-strings-p) | ||
105 | |||
106 | (defcustom org-word-count-only-path-link-types '() | ||
107 | "Link types for which only the path should be counted" | ||
108 | :type '(repeat string) | ||
109 | :safe #'org-word-count-list-of-strings-p) | ||
110 | |||
111 | (defcustom org-word-count-blocks-to-count '("quote" "verse") | ||
112 | "List of blocks which should be included in word count. | ||
113 | |||
114 | Use lower case block names" | ||
115 | :type '(repeat string) | ||
116 | :safe #'org-word-count-list-of-strings-p | ||
117 | :set #'org-word-count--downcase-list-of-strings-set-default) | ||
118 | |||
119 | (defun org-word-count-delayed-update (&rest _) | ||
120 | (if org-word-count-update-timer | ||
121 | (setq org-word-count-update-timer nil) | ||
122 | (setq org-word-count-update-timer | ||
123 | (run-with-idle-timer org-word-count-deletion-idle-timer nil | ||
124 | #'org-word-count-update)))) | ||
125 | |||
126 | (defun org-word-count-force-update () | ||
127 | (interactive) | ||
128 | (message "Counting words...") | ||
129 | (when (timerp org-word-count-update-timer) | ||
130 | (cancel-timer org-word-count-update-timer)) | ||
131 | (org-word-count-update) | ||
132 | (message "Counting words...done")) | ||
133 | |||
134 | (defun org-word-count-update (&rest _) ; Needs variadic parameters, since it's advice | ||
135 | (dlet ((org-word-count-counting t)) | ||
136 | (org-word-count-buffer) | ||
137 | (org-word-count-modeline) | ||
138 | (setq org-word-count-update-timer nil))) | ||
139 | |||
140 | (defun org-word-count-changed (start end length) | ||
141 | (org-word-count-delayed-update)) | ||
142 | |||
143 | (defun org-word-count-buffer () | ||
144 | "Count the words in the buffer." | ||
145 | (when (and (derived-mode-p 'org-mode) | ||
146 | (not (eq org-word-count-word-count 'huge))) | ||
147 | (setq org-word-count-word-count | ||
148 | (cond | ||
149 | ((> (count-words (point-min) (point-max)) | ||
150 | org-word-count-huge-buffer) | ||
151 | 'huge) | ||
152 | (t (org-word-count-aux (point-min) (point-max))))))) | ||
153 | |||
154 | ;;; From org-wc.el: | ||
155 | ;; https://github.com/tesujimath/org-wc/ | ||
156 | (defun org-word-count-aux (beg end) | ||
157 | "Return the number of words between BEG and END." | ||
158 | (let ((wc 0) | ||
159 | subtreecount | ||
160 | (latex-macro-regexp "\\\\[A-Za-z]+\\(\\[[^]]*\\]\\|\\){\\([^}]*\\)}")) | ||
161 | (save-excursion | ||
162 | (goto-char beg) | ||
163 | ;; Handle the case where we start in a drawer | ||
164 | (when (org-at-drawer-p) | ||
165 | (org-end-of-meta-data t)) | ||
166 | (while (< (point) end) | ||
167 | (cond | ||
168 | ;; Handle headlines and subtrees | ||
169 | ((org-at-heading-p) | ||
170 | (cond | ||
171 | ;; Ignore commented and org-wc-ignored-tags trees | ||
172 | ((or (and org-word-count-ignore-commented-trees (org-in-commented-heading-p)) | ||
173 | (cl-intersection org-word-count-ignored-tags (org-get-tags) :test #'string=)) | ||
174 | (org-end-of-subtree t t)) | ||
175 | ;; Re-use count for subtrees already counted | ||
176 | ((setq subtreecount (get-text-property (point) :org-wc)) | ||
177 | (cl-incf wc subtreecount) | ||
178 | (org-end-of-subtree t t)) | ||
179 | ;; Skip counting words in headline | ||
180 | (t (org-word-count--goto-char (point-at-eol) end)))) | ||
181 | ;; Ignore most blocks. | ||
182 | ((when (save-excursion | ||
183 | (beginning-of-line 1) | ||
184 | (looking-at org-block-regexp)) | ||
185 | (if (member (downcase (match-string 1)) org-word-count-blocks-to-count) | ||
186 | (progn ;; go inside block and subtract count of end line | ||
187 | (org-word-count--goto-char (match-beginning 4) end) | ||
188 | (cl-decf wc)) | ||
189 | (org-word-count--goto-char (match-end 0) end)))) | ||
190 | ;; Ignore comments. | ||
191 | ((org-at-comment-p) | ||
192 | (org-word-count--goto-char (point-at-eol) end)) | ||
193 | ;; Ignore drawers. | ||
194 | ((org-at-drawer-p) | ||
195 | (org-end-of-meta-data t)) | ||
196 | ;; Ignore all other #+ lines | ||
197 | ((looking-at "#+") | ||
198 | (org-word-count--goto-char (point-at-eol) end)) | ||
199 | ;; Handle links | ||
200 | ((save-excursion | ||
201 | (when (< (1+ (point-min)) (point)) (backward-char 2)) | ||
202 | (looking-at org-link-bracket-re)) | ||
203 | (let* ((type (car (save-match-data (split-string (match-string 1) ":")))) | ||
204 | (pathstart (+ 1 (length type) (match-beginning 1)))) | ||
205 | (cl-case (cond ((member type org-word-count-ignored-link-types) 'ignore) | ||
206 | ((member type org-word-count-one-word-link-types) 'oneword) | ||
207 | ((member type org-word-count-only-description-link-types) | ||
208 | 'description) | ||
209 | ((member type org-word-count-only-path-link-types) 'path) | ||
210 | ((member type org-word-count-description-or-path-link-types) | ||
211 | 'description-or-path) | ||
212 | (t org-word-count-default-link-count)) | ||
213 | (ignore (org-word-count--goto-char (match-end 0) end)) | ||
214 | (oneword (org-word-count--goto-char (match-end 0) end) | ||
215 | (cl-incf wc)) | ||
216 | (description (if (match-beginning 2) | ||
217 | (goto-char (match-beginning 2)) | ||
218 | (org-word-count--goto-char | ||
219 | (match-end 0) end))) | ||
220 | (path (cl-incf wc (count-words-region pathstart | ||
221 | (match-end 1))) | ||
222 | (org-word-count--goto-char (match-end 0) end)) | ||
223 | (description-or-path | ||
224 | (if (match-beginning 2) | ||
225 | (goto-char (match-beginning 2)) | ||
226 | (cl-incf wc (count-words-region pathstart | ||
227 | (match-end 1))) | ||
228 | (org-word-count--goto-char (match-end 0) end))) | ||
229 | (t (user-error "Error in org-word-count link configuration"))))) | ||
230 | ;; Count latex macros as 1 word, ignoring their arguments. | ||
231 | ((save-excursion | ||
232 | (when (< (point-min) (point)) (backward-char)) | ||
233 | (looking-at latex-macro-regexp)) | ||
234 | (org-word-count--goto-char (match-end 0) end) | ||
235 | (cl-incf wc)) | ||
236 | (t | ||
237 | (and (re-search-forward "\\w+\\W*" end 'skip) | ||
238 | (cl-incf wc)))))) | ||
239 | wc)) | ||
240 | |||
241 | (defun org-word-count--goto-char (char end) | ||
242 | "Moves point to CHAR and from there passes 0+ non-word characters. | ||
243 | Searchers to end as a maximum. | ||
244 | |||
245 | This ensures that we are in an expected state (at the first word | ||
246 | character after some non-word characters) after moving beyond | ||
247 | headlines, links etc." | ||
248 | (goto-char char) | ||
249 | (re-search-forward "\\W*" end 'skip)) | ||
250 | |||
251 | (defvar org-word-count-counting nil | ||
252 | "Are we currently counting?") | ||
253 | |||
254 | (defun org-word-count-recount-widen (&rest _) | ||
255 | (when (and (not org-word-count-counting)) | ||
256 | (org-word-count-update))) | ||
257 | |||
258 | (defun org-word-count-modeline () | ||
259 | (setq org-word-count-string | ||
260 | (cond | ||
261 | ((eq org-word-count-word-count 'huge) | ||
262 | org-word-count-huge-string) | ||
263 | (org-word-count-word-count | ||
264 | (format org-word-count-format | ||
265 | (max 0 (+ org-word-count-word-count | ||
266 | org-word-count-correction)))))) | ||
267 | (force-mode-line-update)) | ||
268 | |||
269 | (define-minor-mode org-word-count-mode | ||
270 | "Count words in `org-mode' buffers in the mode-line." | ||
271 | :lighter "" | ||
272 | :keymap (let ((map (make-sparse-keymap))) | ||
273 | (define-key map (kbd "C-c C-.") #'org-word-count-force-update) | ||
274 | map) | ||
275 | (cond (org-word-count-mode | ||
276 | (org-word-count-buffer) | ||
277 | (add-hook 'after-change-functions | ||
278 | #'org-word-count-delayed-update nil t) | ||
279 | (unless (member '(org-word-count-mode org-word-count-string) | ||
280 | mode-line-misc-info) | ||
281 | (add-to-list 'mode-line-misc-info | ||
282 | '(org-word-count-mode org-word-count-string) | ||
283 | nil | ||
284 | #'equal)) | ||
285 | (dolist (fn org-word-count-update-after-funcs) | ||
286 | (advice-add fn :after #'org-word-count-update))) | ||
287 | (:else | ||
288 | (remove-hook 'after-change-functions | ||
289 | #'org-word-count-delayed-update t) | ||
290 | (setf mode-line-misc-info | ||
291 | (delete '(org-word-count-mode org-word-count-string) | ||
292 | mode-line-misc-info)) | ||
293 | (dolist (fn org-word-count-update-after-funcs) | ||
294 | (advice-remove fn #'org-word-count-update))))) | ||
295 | |||
296 | (provide 'org-word-count) | ||
297 | ;;; org-word-count.el ends here | ||
diff --git a/lisp/yoke.el b/lisp/yoke.el index f9c4d49..8ca94fd 100644 --- a/lisp/yoke.el +++ b/lisp/yoke.el | |||
@@ -84,60 +84,63 @@ Execute BODY afterward. | |||
84 | append (list this next) into ret | 84 | append (list this next) into ret |
85 | finally return (cond ((eq (car (last ret)) nil) | 85 | finally return (cond ((eq (car (last ret)) nil) |
86 | (butlast ret)) | 86 | (butlast ret)) |
87 | (:else ret))))) | 87 | (:else ret)))) |
88 | `(cl-block ,pname | 88 | (r (gensym))) |
89 | (condition-case err | 89 | `(let ((,r (cl-block ,pname |
90 | (progn | 90 | (condition-case err |
91 | ;; Pass `:when' or `:unless' clauses | 91 | (progn |
92 | ,@(cond | 92 | ;; Pass `:when' or `:unless' clauses |
93 | ((and whenp unlessp) | 93 | ,@(cond |
94 | `((when (or (not ,when) ,unless) | 94 | ((and whenp unlessp) |
95 | (cl-return-from ,pname | 95 | `((when (or (not ,when) ,unless) |
96 | (format "%s (abort) :when %S :unless %S" | 96 | (cl-return-from ,pname |
97 | ',pname ',when ',unless))))) | 97 | (format "%s (abort) :when %S :unless %S" |
98 | (whenp | 98 | ',pname ',when ',unless))))) |
99 | `((unless ,when (cl-return-from ,pname | 99 | (whenp |
100 | (format "%s (abort) :when %S" | 100 | `((unless ,when (cl-return-from ,pname |
101 | ',pname ',when))))) | 101 | (format "%s (abort) :when %S" |
102 | (unlessp | 102 | ',pname ',when))))) |
103 | `((when ,unless (cl-return-from ,pname | 103 | (unlessp |
104 | (format "%s (abort) :unless %S" | 104 | `((when ,unless (cl-return-from ,pname |
105 | ',pname ',unless)))))) | 105 | (format "%s (abort) :unless %S" |
106 | ;; Evaluate `:pre' forms | 106 | ',pname ',unless)))))) |
107 | ,@pre | 107 | ;; Evaluate `:pre' forms |
108 | ;; Get prerequisite packages | 108 | ,@pre |
109 | ,@(cl-loop | 109 | ;; Get prerequisite packages |
110 | for (pkg* . yoke-get-args) in depends | 110 | ,@(cl-loop |
111 | collect `(or | 111 | for (pkg* . yoke-get-args) in depends |
112 | (let* ((pkg-spec (yoke-get ,@yoke-get-args | 112 | collect `(or |
113 | :dir ,(format "%s" pkg*))) | 113 | (let* ((pkg-spec (yoke-get ,@yoke-get-args |
114 | (dir (expand-file-name (or (plist-get (cdr pkg-spec) :load) | 114 | :dir ,(format "%s" pkg*))) |
115 | "") | 115 | (dir (expand-file-name (or (plist-get (cdr pkg-spec) :load) |
116 | (car pkg-spec)))) | 116 | "") |
117 | (and dir | 117 | (car pkg-spec)))) |
118 | ,@(if autoload | 118 | (and dir |
119 | `((yoke-generate-autoloads ',pkg* dir)) | 119 | ,@(if autoload |
120 | '(t)) | 120 | `((yoke-generate-autoloads ',pkg* dir)) |
121 | (add-to-list 'yoke-dirs dir nil #'string=))) | 121 | '(t)) |
122 | (cl-return-from ,pname | 122 | (add-to-list 'yoke-dirs dir nil #'string=))) |
123 | (format "Error fetching prerequiste: %s" | 123 | (cl-return-from ,pname |
124 | ',pkg*)))) | 124 | (format "Error fetching prerequiste: %s" |
125 | ;; Download the package, generate autoloads | 125 | ',pkg*)))) |
126 | ,@(when url | 126 | ;; Download the package, generate autoloads |
127 | `((let* ((pkg-spec (yoke-get ,@url :dir ,(format "%s" pkg))) | 127 | ,@(when url |
128 | (,dirvar (expand-file-name (or (plist-get (cdr pkg-spec) :load) | 128 | `((let* ((pkg-spec (yoke-get ,@url :dir ,(format "%s" pkg))) |
129 | "") | 129 | (,dirvar (expand-file-name (or (plist-get (cdr pkg-spec) :load) |
130 | (car pkg-spec)))) | 130 | "") |
131 | ,@(when autoload | 131 | (car pkg-spec)))) |
132 | `((yoke-generate-autoloads ',pkg ,dirvar))) | 132 | ,@(when autoload |
133 | (add-to-list 'yoke-dirs ,dirvar nil #'string=)))) | 133 | `((yoke-generate-autoloads ',pkg ,dirvar))) |
134 | ;; Evaluate the body, optionally after the features in `:after' | 134 | (add-to-list 'yoke-dirs ,dirvar nil #'string=)))) |
135 | ,@(cond (after | 135 | ;; Evaluate the body, optionally after the features in `:after' |
136 | `((yoke-eval-after ,after ,@body))) | 136 | ,@(cond (after |
137 | (:else body))) | 137 | `((yoke-eval-after ,after ,@body))) |
138 | (:success ',package) | 138 | (:else body))) |
139 | (t (message "%s: %s (%s)" ',pname (car err) (cdr err)) | 139 | (:success ',package) |
140 | nil))))) | 140 | (t (message "%s: %s (%s)" ',pname (car err) (cdr err)) |
141 | nil))))) | ||
142 | (when (stringp ,r) (message "%S" ,r)) | ||
143 | ,r))) | ||
141 | 144 | ||
142 | (defun yoke-get (url &rest args) | 145 | (defun yoke-get (url &rest args) |
143 | "\"Get\" URL and and put it in DIR, then add DIR to `load-path'. | 146 | "\"Get\" URL and and put it in DIR, then add DIR to `load-path'. |