summary refs log tree commit diff stats
path: root/lisp
diff options
context:
space:
mode:
authorCase Duckworth2023-01-03 23:02:26 -0600
committerCase Duckworth2023-01-03 23:02:26 -0600
commit259363fd4f21d796c3c6a35be6398aed3f493a73 (patch)
treef2b782a37fa93b4b5be918bbe97c2c62aefd00d0 /lisp
parentmeh (diff)
downloademacs-259363fd4f21d796c3c6a35be6398aed3f493a73.tar.gz
emacs-259363fd4f21d796c3c6a35be6398aed3f493a73.zip
bleh
Diffstat (limited to 'lisp')
-rw-r--r--lisp/+emacs.el6
-rw-r--r--lisp/+org.el56
-rw-r--r--lisp/acdw.el35
-rw-r--r--lisp/dawn.el67
-rw-r--r--lisp/def.el142
-rw-r--r--lisp/org-word-count.el297
-rw-r--r--lisp/yoke.el111
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
239N spaces. See docstring of `cycle-spacing' for the meaning of 239N spaces. See docstring of `cycle-spacing' for the meaning of
240PRESERVE-NL-BACK and MODE." 240PRESERVE-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.
227This 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.
204If PRED is nil or absent, perform FN on all buffers. Both FN and
205PRED are called within a `with-current-buffer' form and without
206arguments."
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)) 39If 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.
51RESET is an argument for internal use." 68Requires `calendar-longitude' and `calendar-latitude' to be set;
69if 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.
11If it doesn't, raise an error. ERROR-TYPE will be the type of
12that error (defaults to `user-error'), and it and ERROR-ARGS are
13passed 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.
44If MAPS is nil or t, bind to `current-global-map'. Otherwise,
45bind each of BINDINGS to the map or list of maps provided.
46
47BINDINGS is a `setq'-style list of pairs of keys and definitions.
48The key part of each binding can be a string, in which case it's
49passed to `kbd', or a vector or anything else `define-key'
50accepts in the KEY position. The definition part, likewise, can
51be any form `define-key' accepts in that position, with this
52addition: if the form is a `defun' form, it will be defined
53before 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.
105NAME and ARGS are passed to the generated `defun' form.
106Each 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
50this correction. (At some point I should correct the underlying
51code... 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.
75This 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
114Use 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.
243Searchers to end as a maximum.
244
245This ensures that we are in an expected state (at the first word
246character after some non-word characters) after moving beyond
247headlines, 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'.