WIP: Pad todo keywords
This commit is contained in:
Adam Porter
parent
6d9f9b21df
commit
be7e8f1bcd
2 changed files with 399 additions and 0 deletions
93
notes.org
93
notes.org
|
|
@ -2485,3 +2485,96 @@ Benchmark results:
|
|||
| uncached | slowest | 3.386679 | 0 | 0 |
|
||||
|
||||
|
||||
** Padding to-do keywords
|
||||
|
||||
Not sure if these results are quite right. =elp-profile= shows them being nearly identical.
|
||||
|
||||
#+BEGIN_SRC elisp
|
||||
(bench-multi-lexical :times 1
|
||||
:forms (("No padding" (org-ql-agenda
|
||||
(and (todo)
|
||||
(not (done))
|
||||
(tags "Emacs"))
|
||||
:sort (priority deadline)
|
||||
:super-groups t))
|
||||
("Padding" (org-ql-agenda**
|
||||
(and (todo)
|
||||
(not (done))
|
||||
(tags "Emacs"))
|
||||
:sort (priority deadline)
|
||||
:super-groups t))))
|
||||
#+END_SRC
|
||||
|
||||
#+RESULTS:
|
||||
| Form | x faster than next | Total runtime | # of GCs | Total GC runtime |
|
||||
|------------+--------------------+---------------+----------+------------------|
|
||||
| No padding | 1.24 | 3.990292 | 0 | 0 |
|
||||
| Padding | slowest | 4.962510 | 1 | 0.731848 |
|
||||
|
||||
#+BEGIN_SRC elisp
|
||||
(elp-profile 5 '(format s- org-ql-)
|
||||
(org-ql-agenda
|
||||
(and (todo)
|
||||
(not (done))
|
||||
(tags "Emacs"))
|
||||
:sort (priority deadline)
|
||||
:super-groups t))
|
||||
#+END_SRC
|
||||
|
||||
#+RESULTS:
|
||||
| Function | Times called | Total time | Average time |
|
||||
|-------------------------------------+--------------+--------------+--------------|
|
||||
| org-ql-agenda--agenda | 5 | 26.580556158 | 5.3161112316 |
|
||||
| org-ql-select | 5 | 19.675620106 | 3.9351240212 |
|
||||
| org-ql--select-cached | 40 | 19.634117127 | 0.4908529281 |
|
||||
| org-ql--select | 40 | 19.630597547 | 0.4907649386 |
|
||||
| org-ql--predicate-tags | 7315 | 10.949397690 | 0.0014968417 |
|
||||
| org-ql--get-tags | 7315 | 9.6837818669 | 0.0013238252 |
|
||||
| org-ql--predicate-todo | 48230 | 3.5819731560 | 7.426...e-05 |
|
||||
| org-ql-agenda--format-element | 2435 | 3.019326507 | 0.0012399698 |
|
||||
| org-ql--predicate-done | 11530 | 1.0185417590 | 8.833...e-05 |
|
||||
| format | 23465 | 0.7703946220 | 3.283...e-05 |
|
||||
| s-join | 5050 | 0.0558378950 | 1.105...e-05 |
|
||||
| org-ql-agenda--add-faces | 2435 | 0.0284022579 | 1.166...e-05 |
|
||||
| org-ql--sort-by | 5 | 0.0263453159 | 0.0052690631 |
|
||||
| org-ql-agenda--add-scheduled-face | 2435 | 0.0208554550 | 8.564...e-06 |
|
||||
| org-ql--priority< | 12372 | 0.0069503440 | 5.617...e-07 |
|
||||
| format-time-string | 244 | 0.0062056230 | 2.543...e-05 |
|
||||
| org-ql-agenda--header-line-format | 5 | 0.0058773409 | 0.0011754682 |
|
||||
| org-ql-agenda--add-todo-face | 2435 | 0.0056749869 | 2.330...e-06 |
|
||||
| org-ql-agenda--font-lock-string | 10 | 0.005474521 | 0.0005474521 |
|
||||
| org-ql-agenda--format-relative-date | 235 | 0.0054201809 | 2.306...e-05 |
|
||||
|
||||
#+BEGIN_SRC elisp
|
||||
(elp-profile 5 '(format s- org-ql-)
|
||||
(org-ql-agenda**
|
||||
(and (todo)
|
||||
(not (done))
|
||||
(tags "Emacs"))
|
||||
:sort (todo priority date)
|
||||
:super-groups t))
|
||||
#+END_SRC
|
||||
|
||||
#+RESULTS:
|
||||
| Function | Times called | Total time | Average time |
|
||||
|-------------------------------------+--------------+--------------+--------------|
|
||||
| org-ql-agenda--agenda** | 5 | 26.333809735 | 5.266761947 |
|
||||
| org-ql-select | 5 | 17.267948398 | 3.4535896797 |
|
||||
| org-ql--select-cached | 40 | 17.227040189 | 0.4306760047 |
|
||||
| org-ql--select | 40 | 17.223625576 | 0.4305906394 |
|
||||
| org-ql--predicate-tags | 7315 | 8.9554375800 | 0.0012242566 |
|
||||
| org-ql--get-tags | 7315 | 8.8911675469 | 0.0012154706 |
|
||||
| org-ql-agenda--format-element* | 2435 | 3.8197904740 | 0.0015687024 |
|
||||
| org-ql--predicate-todo | 48230 | 3.3793621580 | 7.006...e-05 |
|
||||
| org-ql--predicate-done | 11530 | 0.9646284939 | 8.366...e-05 |
|
||||
| s-join | 5050 | 0.0551078480 | 1.091...e-05 |
|
||||
| format | 30100 | 0.0522020250 | 1.734...e-06 |
|
||||
| org-ql-agenda--add-faces | 2435 | 0.0287117619 | 1.179...e-05 |
|
||||
| org-ql--sort-by | 5 | 0.0257972720 | 0.0051594544 |
|
||||
| org-ql-agenda--add-scheduled-face | 2435 | 0.0209146540 | 8.589...e-06 |
|
||||
| org-ql--priority< | 12372 | 0.0069437200 | 5.612...e-07 |
|
||||
| format-time-string | 244 | 0.0061829569 | 2.533...e-05 |
|
||||
| org-ql-agenda--header-line-format | 5 | 0.0058565250 | 0.001171305 |
|
||||
| org-ql-agenda--add-todo-face | 2435 | 0.0056821220 | 2.333...e-06 |
|
||||
| org-ql-agenda--font-lock-string | 10 | 0.005448187 | 0.0005448187 |
|
||||
| org-ql-agenda--format-relative-date | 235 | 0.0053996679 | 2.297...e-05 |
|
||||
|
|
|
|||
306
org-ql-agenda.el
306
org-ql-agenda.el
|
|
@ -72,6 +72,8 @@ Based on `org-agenda-mode-map'.")
|
|||
(defvar org-ql-block-header nil
|
||||
"A string to override the default header in `org-ql-block' agenda blocks.")
|
||||
|
||||
(defvar org-ql-todo-keyword-length nil)
|
||||
|
||||
;; For refreshing results buffers.
|
||||
(defvar org-ql-buffers-files)
|
||||
(defvar org-ql-query)
|
||||
|
|
@ -188,6 +190,130 @@ is used, rather than binding it locally."
|
|||
:super-groups ',super-groups
|
||||
:title ,title))))
|
||||
|
||||
(cl-defmacro org-ql-agenda* (&rest args)
|
||||
"Display an agenda-like buffer of entries in FILES that match QUERY.
|
||||
|
||||
FILES-OR-QUERY is a sexp that is evaluated to get the list of
|
||||
buffers and files to scan.
|
||||
|
||||
QUERY is an `org-ql' query. The query may be passed as
|
||||
FILES-OR-QUERY and QUERY may be left nil, in which case the list
|
||||
of files will automatically be set to the value of calling
|
||||
`org-agenda-files'.
|
||||
|
||||
SORT is passed to `org-ql', which see..
|
||||
|
||||
NARROW, when non-nil, means to respect narrowing in buffers.
|
||||
When nil, buffers are widened before being searched.
|
||||
|
||||
BUFFER, when non-nil, is a buffer or buffer name to display the
|
||||
agenda in, rather than the default.
|
||||
|
||||
SUPER-GROUPS is used to bind variable `org-super-agenda-groups',
|
||||
which see. If t, the existing value of `org-super-agenda-groups'
|
||||
is used, rather than binding it locally."
|
||||
(declare (indent defun)
|
||||
(advertised-calling-convention (files-or-query &optional query &key sort narrow buffer super-groups) nil))
|
||||
(cl-macrolet ((set-keyword-args (args)
|
||||
`(setq sort (plist-get ,args :sort)
|
||||
narrow (plist-get ,args :narrow)
|
||||
buffer (plist-get ,args :buffer)
|
||||
super-groups (plist-get ,args :super-groups))))
|
||||
(let ((files '(org-agenda-files))
|
||||
query sort narrow buffer super-groups)
|
||||
;; Parse args manually (so we can leave FILES nil for a default argument).
|
||||
;; TODO: DRY this and org-ql, I think.
|
||||
(pcase args
|
||||
(`(,arg-files ,arg-pred . ,(and rest (guard (keywordp (car rest)))))
|
||||
;; Files, query, and keyword args (FIXME: Can I combine this and the next one? Does it
|
||||
;; matter if rest is nil or starts with a keyword?)
|
||||
(setq files arg-files
|
||||
query arg-pred)
|
||||
(set-keyword-args rest))
|
||||
(`(,arg-pred . ,(and rest (guard (keywordp (car rest)))))
|
||||
;; Query and keyword args, no files
|
||||
(setq query arg-pred)
|
||||
(set-keyword-args rest))
|
||||
(`(,arg-files ,arg-pred)
|
||||
;; Files and query, no keywords
|
||||
(setq files arg-files
|
||||
query arg-pred))
|
||||
(`(,arg-pred)
|
||||
;; Only query
|
||||
(setq query arg-pred)))
|
||||
(when (eq super-groups t)
|
||||
(setq super-groups org-super-agenda-groups))
|
||||
;; Call --agenda
|
||||
`(org-ql-agenda--agenda* ,files
|
||||
;; TODO: Probably better to just use eval on org-ql rather than reimplementing parts of it here.
|
||||
',query
|
||||
:sort ',sort
|
||||
:buffer ,buffer
|
||||
:narrow ,narrow
|
||||
:super-groups ',super-groups))))
|
||||
|
||||
(cl-defmacro org-ql-agenda** (&rest args)
|
||||
"Display an agenda-like buffer of entries in FILES that match QUERY.
|
||||
|
||||
FILES-OR-QUERY is a sexp that is evaluated to get the list of
|
||||
buffers and files to scan.
|
||||
|
||||
QUERY is an `org-ql' query. The query may be passed as
|
||||
FILES-OR-QUERY and QUERY may be left nil, in which case the list
|
||||
of files will automatically be set to the value of calling
|
||||
`org-agenda-files'.
|
||||
|
||||
SORT is passed to `org-ql', which see..
|
||||
|
||||
NARROW, when non-nil, means to respect narrowing in buffers.
|
||||
When nil, buffers are widened before being searched.
|
||||
|
||||
BUFFER, when non-nil, is a buffer or buffer name to display the
|
||||
agenda in, rather than the default.
|
||||
|
||||
SUPER-GROUPS is used to bind variable `org-super-agenda-groups',
|
||||
which see. If t, the existing value of `org-super-agenda-groups'
|
||||
is used, rather than binding it locally."
|
||||
(declare (indent defun)
|
||||
(advertised-calling-convention (files-or-query &optional query &key sort narrow buffer super-groups) nil))
|
||||
(cl-macrolet ((set-keyword-args (args)
|
||||
`(setq sort (plist-get ,args :sort)
|
||||
narrow (plist-get ,args :narrow)
|
||||
buffer (plist-get ,args :buffer)
|
||||
super-groups (plist-get ,args :super-groups))))
|
||||
(let ((files '(org-agenda-files))
|
||||
query sort narrow buffer super-groups)
|
||||
;; Parse args manually (so we can leave FILES nil for a default argument).
|
||||
;; TODO: DRY this and org-ql, I think.
|
||||
(pcase args
|
||||
(`(,arg-files ,arg-pred . ,(and rest (guard (keywordp (car rest)))))
|
||||
;; Files, query, and keyword args (FIXME: Can I combine this and the next one? Does it
|
||||
;; matter if rest is nil or starts with a keyword?)
|
||||
(setq files arg-files
|
||||
query arg-pred)
|
||||
(set-keyword-args rest))
|
||||
(`(,arg-pred . ,(and rest (guard (keywordp (car rest)))))
|
||||
;; Query and keyword args, no files
|
||||
(setq query arg-pred)
|
||||
(set-keyword-args rest))
|
||||
(`(,arg-files ,arg-pred)
|
||||
;; Files and query, no keywords
|
||||
(setq files arg-files
|
||||
query arg-pred))
|
||||
(`(,arg-pred)
|
||||
;; Only query
|
||||
(setq query arg-pred)))
|
||||
(when (eq super-groups t)
|
||||
(setq super-groups org-super-agenda-groups))
|
||||
;; Call --agenda
|
||||
`(org-ql-agenda--agenda** ,files
|
||||
;; TODO: Probably better to just use eval on org-ql rather than reimplementing parts of it here.
|
||||
',query
|
||||
:sort ',sort
|
||||
:buffer ,buffer
|
||||
:narrow ,narrow
|
||||
:super-groups ',super-groups))))
|
||||
|
||||
;;;; Commands
|
||||
|
||||
;; TODO: This is called `org-ql-search' but it's in org-ql-agenda.el because
|
||||
|
|
@ -409,6 +535,109 @@ Runs `org-occur-hook' after making the sparse tree."
|
|||
(org-agenda-finalize)
|
||||
(goto-char (point-min)))))
|
||||
|
||||
(cl-defun org-ql-agenda--agenda* (buffers-files query &key entries sort buffer narrow super-groups)
|
||||
"FIXME: Docstring"
|
||||
(declare (indent defun))
|
||||
(when (and super-groups (not org-super-agenda-mode))
|
||||
(user-error "`org-super-agenda-mode' must be activated to use grouping"))
|
||||
(let* ((org-super-agenda-groups super-groups)
|
||||
(entries (or entries
|
||||
(--> (org-ql-select buffers-files
|
||||
query
|
||||
:sort sort
|
||||
:narrow narrow
|
||||
:action (lambda ()
|
||||
(->> (org-element-headline-parser (line-end-position))
|
||||
org-ql--add-markers))))))
|
||||
(org-ql-todo-keyword-length (cl-loop for e in entries
|
||||
for todo-keyword = (org-element-property :todo-keyword e)
|
||||
when todo-keyword
|
||||
maximizing (length todo-keyword)))
|
||||
(string (--> entries
|
||||
(mapcar #'org-ql-agenda--format-element* it)
|
||||
(cond ((bound-and-true-p org-super-agenda-mode) (org-super-agenda--group-items it))
|
||||
(t it))
|
||||
(s-join "\n" it)))
|
||||
(buffer (cl-etypecase buffer
|
||||
(string (org-ql-agenda--buffer buffer))
|
||||
(null (org-ql-agenda--buffer buffer))
|
||||
(buffer buffer)))
|
||||
(map (copy-keymap org-agenda-mode-map))
|
||||
(inhibit-read-only t))
|
||||
(define-key map "g" #'org-ql-search-refresh)
|
||||
(with-current-buffer buffer
|
||||
(use-local-map map)
|
||||
;; Prepare buffer, saving data for refreshing.
|
||||
(setq-local org-ql-buffers-files buffers-files)
|
||||
(setq-local org-ql-query query)
|
||||
(setq-local org-ql-sort sort)
|
||||
(setq-local org-ql-narrow narrow)
|
||||
(setq-local org-ql-super-groups super-groups)
|
||||
(setq-local header-line-format (org-ql-agenda--header-line-format buffers-files query))
|
||||
;; Clear buffer, insert entries, etc.
|
||||
(erase-buffer)
|
||||
(insert string)
|
||||
(pop-to-buffer (current-buffer))
|
||||
(org-agenda-finalize)
|
||||
(goto-char (point-min)))))
|
||||
|
||||
(defun org-ql-agenda-todo-keyword-max-length ()
|
||||
"FIXME: Docstring."
|
||||
(->> org-todo-keywords
|
||||
(-map #'cdr)
|
||||
-flatten
|
||||
(--remove (string= "|" it))
|
||||
(--map (progn
|
||||
(string-match (rx (1+ (not (in "(")))) it)
|
||||
(length (match-string 0 it))))
|
||||
(apply #'max)))
|
||||
|
||||
(defvar org-ql-agenda-todo-format)
|
||||
|
||||
(cl-defun org-ql-agenda--agenda** (buffers-files query &key entries sort buffer narrow super-groups)
|
||||
"FIXME: Docstring"
|
||||
(declare (indent defun))
|
||||
(when (and super-groups (not org-super-agenda-mode))
|
||||
(user-error "`org-super-agenda-mode' must be activated to use grouping"))
|
||||
(let* ((org-super-agenda-groups super-groups)
|
||||
(entries (or entries
|
||||
(--> (org-ql-select buffers-files
|
||||
query
|
||||
:sort sort
|
||||
:narrow narrow
|
||||
:action (lambda ()
|
||||
(->> (org-element-headline-parser (line-end-position))
|
||||
org-ql--add-markers))))))
|
||||
(org-ql-todo-keyword-length (org-ql-agenda-todo-keyword-max-length))
|
||||
(org-ql-agenda-todo-format (concat "%" (number-to-string org-ql-todo-keyword-length) "s"))
|
||||
(string (--> entries
|
||||
(mapcar #'org-ql-agenda--format-element* it)
|
||||
(cond ((bound-and-true-p org-super-agenda-mode) (org-super-agenda--group-items it))
|
||||
(t it))
|
||||
(s-join "\n" it)))
|
||||
(buffer (cl-etypecase buffer
|
||||
(string (org-ql-agenda--buffer buffer))
|
||||
(null (org-ql-agenda--buffer buffer))
|
||||
(buffer buffer)))
|
||||
(map (copy-keymap org-agenda-mode-map))
|
||||
(inhibit-read-only t))
|
||||
(define-key map "g" #'org-ql-search-refresh)
|
||||
(with-current-buffer buffer
|
||||
(use-local-map map)
|
||||
;; Prepare buffer, saving data for refreshing.
|
||||
(setq-local org-ql-buffers-files buffers-files)
|
||||
(setq-local org-ql-query query)
|
||||
(setq-local org-ql-sort sort)
|
||||
(setq-local org-ql-narrow narrow)
|
||||
(setq-local org-ql-super-groups super-groups)
|
||||
(setq-local header-line-format (org-ql-agenda--header-line-format buffers-files query))
|
||||
;; Clear buffer, insert entries, etc.
|
||||
(erase-buffer)
|
||||
(insert string)
|
||||
(pop-to-buffer (current-buffer))
|
||||
(org-agenda-finalize)
|
||||
(goto-char (point-min)))))
|
||||
|
||||
(defun org-ql-agenda-block (query)
|
||||
"Insert items for QUERY into current buffer.
|
||||
QUERY should be an `org-ql' query form. Intended to be used as a
|
||||
|
|
@ -576,6 +805,83 @@ return an empty string."
|
|||
'tags tag-list
|
||||
'org-habit-p habit-property)))))
|
||||
|
||||
(defun org-ql-agenda--format-element* (element)
|
||||
;; This essentially needs to do what `org-agenda-format-item' does,
|
||||
;; which is a lot. We are a long way from that, but it's a start.
|
||||
"Return ELEMENT as a string with text-properties set by its property list.
|
||||
Its property list should be the second item in the list, as
|
||||
returned by `org-element-parse-buffer'. If ELEMENT is nil,
|
||||
return an empty string."
|
||||
(if (not element)
|
||||
""
|
||||
(let* ((properties (cadr element))
|
||||
;; Remove the :parent property, which so bloats the size of
|
||||
;; the properties list that it makes it essentially
|
||||
;; impossible to debug, because Emacs takes approximately
|
||||
;; forever to show it in the minibuffer or with
|
||||
;; `describe-text-properties'. FIXME: Shouldn't be necessary
|
||||
;; anymore since we're not parsing the whole buffer.
|
||||
|
||||
;; Also, remove ":" from key symbols. FIXME: It would be
|
||||
;; better to avoid this somehow. At least, we should use a
|
||||
;; function to convert plists to alists, if possible.
|
||||
(properties (cl-loop for (key val) on properties by #'cddr
|
||||
for symbol = (intern (cl-subseq (symbol-name key) 1))
|
||||
unless (member symbol '(parent))
|
||||
append (list symbol val)))
|
||||
;; TODO: --add-faces is used to add the :relative-due-date property, but that fact is
|
||||
;; hidden by doing it through --add-faces (which calls --add-scheduled-face and
|
||||
;; --add-deadline-face), and doing it in this form that gets the title hides it even more.
|
||||
;; Adding the relative due date property should probably be done explicitly and separately
|
||||
;; (which would also make it easier to do it independently of faces, etc).
|
||||
(title (--> (org-ql-agenda--add-faces element)
|
||||
(org-element-property :raw-value it)
|
||||
(org-link-display-format it)))
|
||||
(todo-keyword (-some--> (org-element-property :todo-keyword element)
|
||||
(org-ql-agenda--add-todo-face it)
|
||||
(format org-ql-agenda-todo-format it)))
|
||||
;; FIXME: Figure out whether I should use `org-agenda-use-tag-inheritance' or `org-use-tag-inheritance', etc.
|
||||
(tag-list (if org-use-tag-inheritance
|
||||
;; FIXME: Note that tag inheritance cannot be used here unless markers are
|
||||
;; added, otherwise we can't go to the item's buffer to look for inherited
|
||||
;; tags. (Or does `org-element-headline-parser' parse inherited tags too? I
|
||||
;; forget...)
|
||||
(if-let ((marker (or (org-element-property :org-hd-marker element)
|
||||
(org-element-property :org-marker element))))
|
||||
(with-current-buffer (marker-buffer marker)
|
||||
;; I wish `org-get-tags' used the correct buffer automatically.
|
||||
(org-get-tags marker (not org-use-tag-inheritance)))
|
||||
;; No marker found
|
||||
(warn "No marker found for item: %s" title)
|
||||
(org-element-property :tags element))
|
||||
(org-element-property :tags element)))
|
||||
(tag-string (when tag-list
|
||||
(--> tag-list
|
||||
(s-join ":" it)
|
||||
(s-wrap it ":")
|
||||
(org-add-props it nil 'face 'org-tag))))
|
||||
;; (category (org-element-property :category element))
|
||||
(priority-string (-some->> (org-element-property :priority element)
|
||||
(char-to-string)
|
||||
(format "[#%s]")
|
||||
(org-ql-agenda--add-priority-face)))
|
||||
(habit-property (org-with-point-at (org-element-property :begin element)
|
||||
(when (org-is-habit-p)
|
||||
(org-habit-parse-todo))))
|
||||
(due-string (pcase (org-element-property :relative-due-date element)
|
||||
('nil " ")
|
||||
(string (format "%8s" (org-add-props string nil 'face 'org-ql-agenda-due-date)))))
|
||||
(string (s-join " " (-non-nil (list due-string todo-keyword priority-string title tag-string)))))
|
||||
(remove-list-of-text-properties 0 (length string) '(line-prefix) string)
|
||||
;; Add all the necessary properties and faces to the whole string
|
||||
(--> string
|
||||
;; FIXME: Use proper prefix
|
||||
(concat " " it)
|
||||
(org-add-props it properties
|
||||
'todo-state todo-keyword
|
||||
'tags tag-list
|
||||
'org-habit-p habit-property)))))
|
||||
|
||||
(defun org-ql-agenda--add-faces (element)
|
||||
"Return ELEMENT with deadline and scheduled faces added."
|
||||
(->> element
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue