WIP: Split org-ql-agenda into org-ql-view and org-ql-search
This commit is contained in:
Adam Porter
parent
1ff21dc0c8
commit
6d9f9b21df
2 changed files with 564 additions and 0 deletions
202
org-ql-search.el
Normal file
202
org-ql-search.el
Normal file
|
|
@ -0,0 +1,202 @@
|
|||
;;; org-ql-search.el --- Search commands for org-ql -*- lexical-binding: t; -*-
|
||||
|
||||
;; Author: Adam Porter <adam@alphapapa.net>
|
||||
;; Url: https://github.com/alphapapa/org-ql
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This library is part of the package `org-ql'; it's not a standalone
|
||||
;; library. It displays buffers similar to Org Agenda buffers, based
|
||||
;; on `org-ql' queries.
|
||||
|
||||
;;; License:
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
|
||||
(require 'dash)
|
||||
(require 's)
|
||||
|
||||
(require 'org-ql)
|
||||
(require 'org-ql-view)
|
||||
|
||||
;;;; Variables
|
||||
|
||||
(defvar org-ql-views)
|
||||
|
||||
;; From `org-super-agenda'.
|
||||
(defvar org-super-agenda-mode)
|
||||
(defvar org-super-agenda-groups)
|
||||
(defvar org-super-agenda-auto-selector-keywords)
|
||||
(declare-function org-super-agenda--group-items "ext:org-super-agenda")
|
||||
|
||||
;; For refreshing results buffers.
|
||||
(defvar org-ql-view-buffers-files)
|
||||
(defvar org-ql-view-query)
|
||||
(defvar org-ql-view-sort)
|
||||
(defvar org-ql-view-narrow)
|
||||
(defvar org-ql-view-super-groups)
|
||||
(defvar org-ql-view-title)
|
||||
|
||||
;;;; Commands
|
||||
|
||||
;;;###autoload
|
||||
(cl-defun org-ql-search (buffers-files query &key buffer narrow super-groups sort title)
|
||||
"Read QUERY and search with `org-ql'.
|
||||
Interactively, prompt for these variables:
|
||||
|
||||
BUFFERS-FILES: A list of buffers and/or files to search.
|
||||
Interactively, may also be:
|
||||
|
||||
- `buffer': search the current buffer
|
||||
- `all': search all Org buffers
|
||||
- `agenda': search buffers returned by the function `org-agenda-files'
|
||||
- An expression which evaluates to a list of files/buffers
|
||||
- A space-separated list of file or buffer names
|
||||
|
||||
SUPER-GROUPS: An `org-super-agenda' group set. See variable
|
||||
`org-super-agenda-groups'.
|
||||
|
||||
NARROW: When non-nil, don't widen buffers before
|
||||
searching. Interactively, with prefix, leave narrowed.
|
||||
|
||||
SORT: One or a list of `org-ql' sorting functions, like `date' or
|
||||
`priority'.
|
||||
|
||||
TITLE: An optional string displayed in the header.
|
||||
|
||||
BUFFER: Optionally, a buffer or name of a buffer in which to
|
||||
display the results. Set automatically when nil."
|
||||
(declare (indent defun))
|
||||
(interactive (list (pcase-exhaustive (completing-read "Buffers/Files: "
|
||||
(list 'buffer 'agenda 'all))
|
||||
("agenda" (org-agenda-files))
|
||||
("all" (--select (equal (buffer-local-value 'major-mode it) 'org-mode)
|
||||
(buffer-list)))
|
||||
("buffer" (current-buffer))
|
||||
((and form (guard (rx bos "("))) (-flatten (eval (read form))))
|
||||
(else (s-split (rx (1+ space)) else)))
|
||||
(read-minibuffer "Query: ")
|
||||
:narrow (eq current-prefix-arg '(4))
|
||||
:super-groups (when (bound-and-true-p org-super-agenda-auto-selector-keywords)
|
||||
(pcase (completing-read "Group by: "
|
||||
(append (list "Don't group"
|
||||
"Global super-groups")
|
||||
(cl-loop for type in org-super-agenda-auto-selector-keywords
|
||||
collect (substring (symbol-name type) 6))))
|
||||
("Global super-groups" org-super-agenda-groups)
|
||||
("Don't group" nil)
|
||||
(property (list (list (intern (concat ":auto-" property)))))))
|
||||
:sort (pcase (completing-read "Sort by: "
|
||||
(list "Don't sort"
|
||||
"date"
|
||||
"deadline"
|
||||
"priority"
|
||||
"scheduled"
|
||||
"todo"))
|
||||
("Don't sort" nil)
|
||||
(sort (intern sort)))))
|
||||
(let* ((results (org-ql-select buffers-files query
|
||||
:action 'element-with-markers
|
||||
:narrow narrow
|
||||
:sort sort))
|
||||
(strings (-map #'org-ql-view--format-element results))
|
||||
;; Bind variables for `org-ql-view--display' to set.
|
||||
(org-ql-view-buffers-files buffers-files)
|
||||
(org-ql-view-query query)
|
||||
(org-ql-view-sort sort)
|
||||
(org-ql-view-narrow narrow)
|
||||
(org-ql-view-super-groups super-groups)
|
||||
(org-ql-view-title title))
|
||||
(when super-groups
|
||||
(setf strings (org-super-agenda--group-items strings)))
|
||||
(org-ql-view--display
|
||||
:buffer (or buffer
|
||||
(format "*Org QL Search: %s*"
|
||||
(or title
|
||||
(format "%S in %S" query buffers-files))))
|
||||
:header (org-ql-view--header-line-format buffers-files query title)
|
||||
:string (s-join "\n" strings))))
|
||||
|
||||
(defun org-ql-search-refresh ()
|
||||
"Refresh current `org-ql-search' buffer."
|
||||
(interactive)
|
||||
(let ((old-pos (point)))
|
||||
(org-ql-search org-ql-view-buffers-files
|
||||
org-ql-view-query
|
||||
:sort org-ql-view-sort
|
||||
:narrow org-ql-view-narrow
|
||||
:super-groups org-ql-view-super-groups
|
||||
:title org-ql-view-title
|
||||
:buffer (current-buffer))
|
||||
(goto-char old-pos)))
|
||||
|
||||
(defun org-ql-search-save ()
|
||||
"Save current `org-ql-search' buffer to `org-ql-views'."
|
||||
(interactive)
|
||||
(let* ((name (read-string "Save view as: "))
|
||||
(buffers-files-sexp (cl-etypecase org-ql-view-buffers-files
|
||||
(string org-ql-view-buffers-files)
|
||||
(list `(list ,@org-ql-view-buffers-files))
|
||||
(null nil)))
|
||||
(function `(lambda ()
|
||||
(interactive)
|
||||
(org-ql-search ,buffers-files-sexp
|
||||
',org-ql-view-query
|
||||
:sort ',org-ql-view-sort
|
||||
:narrow ,org-ql-view-narrow
|
||||
:groups ',org-ql-view-super-groups
|
||||
:title ,name))))
|
||||
(map-put org-ql-views name function #'equal)
|
||||
(customize-set-variable 'org-ql-views org-ql-views)
|
||||
(customize-mark-to-save 'org-ql-views)))
|
||||
|
||||
(defun org-ql-search-block (query)
|
||||
"Insert items for QUERY into current buffer.
|
||||
QUERY should be an `org-ql' query form. Like other agenda block
|
||||
commands, it searches files returned by function
|
||||
`org-agenda-files'. Intended to be used as a user-defined
|
||||
function in `org-agenda-custom-commands'. QUERY corresponds to
|
||||
the `match' item in the custom command form. Inserts a newline
|
||||
after the block."
|
||||
(when-let* ((from (org-agenda-files nil 'ifmode))
|
||||
(items (org-ql-select from
|
||||
query :action 'element-with-markers)))
|
||||
;; Not sure if calling the prepare function is necessary, but let's follow the pattern.
|
||||
(org-agenda-prepare)
|
||||
;; FIXME: `org-agenda--insert-overriding-header' is from an Org version newer than
|
||||
;; I'm using. Should probably declare it as a minimum Org version after upgrading.
|
||||
;; (org-agenda--insert-overriding-header (org-ql-search--header-line-format from query))
|
||||
(insert (org-add-props (org-ql-view--header-line-format from query)
|
||||
nil 'face 'org-agenda-structure) "\n")
|
||||
;; Calling `org-agenda-finalize' should be unnecessary, because in a "series" agenda,
|
||||
;; `org-agenda-multi' is bound non-nil, in which case `org-agenda-finalize' does nothing.
|
||||
;; But we do call `org-agenda-finalize-entries', which allows `org-super-agenda' to work.
|
||||
(->> items
|
||||
(-map #'org-ql-view--format-element)
|
||||
org-agenda-finalize-entries
|
||||
insert)
|
||||
(insert "\n")))
|
||||
|
||||
;;;###autoload
|
||||
(defalias 'org-ql-block 'org-ql-search-block)
|
||||
|
||||
;;;; Footer
|
||||
|
||||
(provide 'org-ql-search)
|
||||
|
||||
;;; org-ql-search.el ends here
|
||||
362
org-ql-view.el
Normal file
362
org-ql-view.el
Normal file
|
|
@ -0,0 +1,362 @@
|
|||
;;; org-ql-view.el --- Agenda-like view based on org-ql -*- lexical-binding: t; -*-
|
||||
|
||||
;; Author: Adam Porter <adam@alphapapa.net>
|
||||
;; Url: https://github.com/alphapapa/org-ql
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This library is part of the package `org-ql'; it's not a standalone
|
||||
;; library. It displays strings in buffers similar to Org Agenda
|
||||
;; buffers.
|
||||
|
||||
;;; License:
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'map)
|
||||
(require 'org)
|
||||
(require 'org-element)
|
||||
(require 'org-agenda)
|
||||
(require 'seq)
|
||||
(require 'rx)
|
||||
|
||||
(require 'org-ql)
|
||||
|
||||
(require 'dash)
|
||||
(require 's)
|
||||
|
||||
;;;; Compatibility
|
||||
|
||||
(defvar org-super-agenda-auto-selector-keywords)
|
||||
(defvar org-super-agenda-groups)
|
||||
(defvar org-super-agenda-mode)
|
||||
(declare-function org-super-agenda--group-items "ext:org-super-agenda")
|
||||
|
||||
(when (version< org-version "9.2")
|
||||
(defalias 'org-get-tags #'org-get-tags-at))
|
||||
|
||||
;;;; Faces
|
||||
|
||||
(defface org-ql-view-due-date
|
||||
'((t (:slant italic :weight bold)))
|
||||
"Face for due dates in `org-ql-view' views."
|
||||
:group 'org-ql)
|
||||
|
||||
;;;; Variables
|
||||
|
||||
(defvar org-ql-view-buffer-name "*Org-QL View*"
|
||||
"Name of default `org-ql-view' buffer.")
|
||||
|
||||
(defvar org-ql-view-map
|
||||
;; FIXME: Discrepancy between org-ql-search and org-ql-view here.
|
||||
(let ((map (copy-keymap org-agenda-mode-map)))
|
||||
(define-key map "g" #'org-ql-search-refresh)
|
||||
(define-key map (kbd "C-x C-s") #'org-ql-search-save)
|
||||
map)
|
||||
"Keymap for `org-ql-view', `org-ql-search', and `org-ql-views' views.
|
||||
Based on `org-agenda-mode-map'.")
|
||||
|
||||
;; For refreshing results buffers.
|
||||
(defvar-local org-ql-view-buffers-files nil)
|
||||
(defvar-local org-ql-view-query nil)
|
||||
(defvar-local org-ql-view-sort nil)
|
||||
(defvar-local org-ql-view-narrow nil)
|
||||
(defvar-local org-ql-view-super-groups nil)
|
||||
(defvar-local org-ql-view-title nil)
|
||||
|
||||
;;;; Functions
|
||||
|
||||
(cl-defun org-ql-view--display (&key buffer header string)
|
||||
"Display STRING in `org-ql-view' BUFFER.
|
||||
|
||||
BUFFER may be a buffer, or a string naming a buffer, which is
|
||||
reused if it already exists.
|
||||
|
||||
HEADER is a string displayed in the buffer's header line.
|
||||
|
||||
The following special variables, if non-nil, are set
|
||||
buffer-locally to preserve their value in the buffer for
|
||||
subsequent refreshing of the buffer: `org-ql-view-buffers-files',
|
||||
`org-ql-view-query', `org-ql-view-sort', `org-ql-view-narrow',
|
||||
`org-ql-view-super-groups', `org-ql-title.'"
|
||||
;; TODO: Rename `entries' to `elements'.
|
||||
(declare (indent defun))
|
||||
(let* ((buffer (cl-etypecase buffer
|
||||
(string (org-ql-view--buffer buffer))
|
||||
(null (org-ql-view--buffer buffer))
|
||||
(buffer buffer))))
|
||||
(with-current-buffer buffer
|
||||
(use-local-map org-ql-view-map)
|
||||
;; Prepare buffer, saving data for refreshing.
|
||||
(cl-loop for symbol in (list 'org-ql-view-buffers-files 'org-ql-view-query
|
||||
'org-ql-view-sort 'org-ql-view-narrow
|
||||
'org-ql-view-super-groups 'org-ql-view-title)
|
||||
do (set (make-local-variable symbol) (symbol-value symbol)))
|
||||
(setq-local header-line-format header)
|
||||
;; Clear buffer, insert entries, etc.
|
||||
(let ((inhibit-read-only t))
|
||||
(erase-buffer)
|
||||
(insert string)
|
||||
(pop-to-buffer (current-buffer))
|
||||
(org-agenda-finalize)
|
||||
(goto-char (point-min))))))
|
||||
|
||||
(defun org-ql-view--header-line-format (buffers-files query &optional title)
|
||||
"Return header-line-format for BUFFERS-FILES and QUERY."
|
||||
(let* ((title (if title
|
||||
(concat (propertize "View:" 'face 'org-agenda-structure)
|
||||
title " ")
|
||||
""))
|
||||
(query-formatted (format "%S" query))
|
||||
(query-formatted (propertize (org-ql-view--font-lock-string 'emacs-lisp-mode query-formatted)
|
||||
'help-echo query-formatted))
|
||||
(query-width (length query-formatted))
|
||||
(available-width (max 0 (- (window-width)
|
||||
(length "In: ")
|
||||
(length "Query: ")
|
||||
query-width 4)))
|
||||
(buffers-files-formatted (format "%S" buffers-files))
|
||||
(buffers-files-formatted (propertize (->> buffers-files-formatted
|
||||
(org-ql-view--font-lock-string 'emacs-lisp-mode)
|
||||
(s-truncate available-width))
|
||||
'help-echo buffers-files-formatted)))
|
||||
(concat title
|
||||
(propertize "Query:" 'face 'org-agenda-structure)
|
||||
query-formatted " "
|
||||
(propertize "In:" 'face 'org-agenda-structure)
|
||||
buffers-files-formatted)))
|
||||
|
||||
(defun org-ql-view--font-lock-string (mode s)
|
||||
"Return string S font-locked according to MODE."
|
||||
;; FIXME: Is this the proper way to do this? It works, but I feel like there must be a built-in way...
|
||||
(with-temp-buffer
|
||||
(delay-mode-hooks
|
||||
(insert s)
|
||||
(funcall mode)
|
||||
(font-lock-ensure)
|
||||
(buffer-string))))
|
||||
|
||||
(defun org-ql-view--buffer (&optional name)
|
||||
"Return Agenda NG buffer, creating it if necessary.
|
||||
If NAME is non-nil, return buffer by that name instead of using
|
||||
default buffer."
|
||||
(with-current-buffer (get-buffer-create (or name org-ql-view-buffer-name))
|
||||
(unless (eq major-mode 'org-agenda-mode)
|
||||
(org-agenda-mode))
|
||||
(current-buffer)))
|
||||
|
||||
(defun org-ql-view--format-relative-date (difference)
|
||||
;; MAYBE: Make this a `defsubst'.
|
||||
"Return relative date string for DIFFERENCE.
|
||||
DIFFERENCE should be an integer number of days, positive for
|
||||
dates in the past, and negative for dates in the future."
|
||||
(cond ((> difference 0)
|
||||
(format "%sd ago" difference))
|
||||
((< difference 0)
|
||||
(format "in %sd" (* -1 difference)))
|
||||
(t "today")))
|
||||
|
||||
;;;; Faces/properties
|
||||
|
||||
(defun org-ql-view--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-view--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-view--add-todo-face 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-view--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 " %s " (org-add-props string nil 'face 'org-ql-view-due-date)))))
|
||||
(string (s-join " " (-non-nil (list todo-keyword priority-string title due-string 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-view--add-faces (element)
|
||||
"Return ELEMENT with deadline and scheduled faces added."
|
||||
(->> element
|
||||
(org-ql-view--add-scheduled-face)
|
||||
(org-ql-view--add-deadline-face)))
|
||||
|
||||
(defun org-ql-view--add-priority-face (string)
|
||||
"Return STRING with priority face added."
|
||||
(when (string-match "\\(\\[#\\(.\\)\\]\\)" string)
|
||||
(let ((face (org-get-priority-face (string-to-char (match-string 2 string)))))
|
||||
(org-add-props string nil 'face face 'font-lock-fontified t))))
|
||||
|
||||
(defun org-ql-view--add-scheduled-face (element)
|
||||
"Add faces to ELEMENT's title for its scheduled status."
|
||||
;; NOTE: Also adding prefix
|
||||
(if-let ((scheduled-date (org-element-property :scheduled element)))
|
||||
(let* ((todo-keyword (org-element-property :todo-keyword element))
|
||||
(today-day-number (org-today))
|
||||
;; (current-day-number
|
||||
;; NOTE: Not currently used, but if we ever implement a more "traditional" agenda that
|
||||
;; shows perspective of multiple days at once, we'll need this, so I'll leave it for now.
|
||||
;; ;; FIXME: This is supposed to be the, shall we say,
|
||||
;; ;; pretend, or perspective, day number that this pass
|
||||
;; ;; through the agenda is being made for. We need to
|
||||
;; ;; either set this in the calling function, set it here,
|
||||
;; ;; or accomplish this in a different way. See
|
||||
;; ;; `org-agenda-get-scheduled' and where `date' is set in
|
||||
;; ;; `org-agenda-list'.
|
||||
;; today-day-number)
|
||||
(scheduled-day-number (org-time-string-to-absolute
|
||||
(org-element-timestamp-interpreter scheduled-date 'ignore)))
|
||||
(difference-days (- today-day-number scheduled-day-number))
|
||||
(relative-due-date (org-add-props (org-ql-view--format-relative-date difference-days) nil
|
||||
'help-echo (org-element-property :raw-value scheduled-date)))
|
||||
;; FIXME: Unused for now:
|
||||
;; (show-all (or (eq org-agenda-repeating-timestamp-show-all t)
|
||||
;; (member todo-keyword org-agenda-repeating-timestamp-show-all)))
|
||||
;; FIXME: Unused for now: (sexp-p (string-prefix-p "%%" raw-value))
|
||||
;; FIXME: Unused for now: (raw-value (org-element-property :raw-value scheduled-date))
|
||||
;; FIXME: I don't remember what `repeat-day-number' was for, but we aren't using it.
|
||||
;; But I'll leave it here for now.
|
||||
;; (repeat-day-number (cond (sexp-p (org-time-string-to-absolute scheduled-date))
|
||||
;; ((< today-day-number scheduled-day-number) scheduled-day-number)
|
||||
;; (t (org-time-string-to-absolute
|
||||
;; raw-value
|
||||
;; (if show-all
|
||||
;; current-day-number
|
||||
;; today-day-number)
|
||||
;; 'future
|
||||
;; ;; FIXME: I don't like
|
||||
;; ;; calling `current-buffer'
|
||||
;; ;; here. If the element has
|
||||
;; ;; a marker, we should use
|
||||
;; ;; that.
|
||||
;; (current-buffer)
|
||||
;; (org-element-property :begin element)))))
|
||||
(face (cond ((member todo-keyword org-done-keywords) 'org-agenda-done)
|
||||
((= today-day-number scheduled-day-number) 'org-scheduled-today)
|
||||
((> today-day-number scheduled-day-number) 'org-scheduled-previously)
|
||||
(t 'org-scheduled)))
|
||||
(title (--> (org-element-property :raw-value element)
|
||||
(org-add-props it nil
|
||||
'face face)))
|
||||
(properties (--> (cadr element)
|
||||
(plist-put it :title title)
|
||||
(plist-put it :relative-due-date relative-due-date))))
|
||||
(list (car element)
|
||||
properties))
|
||||
;; Not scheduled
|
||||
element))
|
||||
|
||||
(defun org-ql-view--add-deadline-face (element)
|
||||
"Add faces to ELEMENT's title for its deadline status.
|
||||
Also store relative due date as string in `:relative-due-date'
|
||||
property."
|
||||
;; FIXME: In my config, doesn't apply orange for approaching deadline the same way the Org Agenda does.
|
||||
(if-let ((deadline-date (org-element-property :deadline element)))
|
||||
(let* ((today-day-number (org-today))
|
||||
(deadline-day-number (org-time-string-to-absolute
|
||||
(org-element-timestamp-interpreter deadline-date 'ignore)))
|
||||
(difference-days (- today-day-number deadline-day-number))
|
||||
(relative-due-date (org-add-props (org-ql-view--format-relative-date difference-days) nil
|
||||
'help-echo (org-element-property :raw-value deadline-date)))
|
||||
;; FIXME: Unused for now: (todo-keyword (org-element-property :todo-keyword element))
|
||||
;; FIXME: Unused for now: (done-p (member todo-keyword org-done-keywords))
|
||||
;; FIXME: Unused for now: (today-p (= today-day-number deadline-day-number))
|
||||
(deadline-passed-fraction (--> (- deadline-day-number today-day-number)
|
||||
(float it)
|
||||
(/ it (max org-deadline-warning-days 1))
|
||||
(- 1 it)))
|
||||
(face (org-agenda-deadline-face deadline-passed-fraction))
|
||||
(title (--> (org-element-property :raw-value element)
|
||||
(org-add-props it nil
|
||||
'face face)))
|
||||
(properties (--> (cadr element)
|
||||
(plist-put it :title title)
|
||||
(plist-put it :relative-due-date relative-due-date))))
|
||||
(list (car element)
|
||||
properties))
|
||||
;; No deadline
|
||||
element))
|
||||
|
||||
(defun org-ql-view--add-todo-face (keyword)
|
||||
"Return KEYWORD with TODO face added."
|
||||
(when-let ((face (org-get-todo-face keyword)))
|
||||
(org-add-props keyword nil 'face face)))
|
||||
|
||||
;;;; Footer
|
||||
|
||||
(provide 'org-ql-view)
|
||||
|
||||
;;; org-ql-view.el ends here
|
||||
Loading…
Add table
Add a link
Reference in a new issue