Merge remote-tracking branch 'gh/master' into HEAD
This commit is contained in:
Salih Muhammed
commit
8b3bb74c94
13 changed files with 1084 additions and 492 deletions
121
org-ql-view.el
121
org-ql-view.el
|
|
@ -40,10 +40,8 @@
|
|||
|
||||
(require 'org-ql)
|
||||
|
||||
;; FIXME: check-declare declares "function not found", even though it
|
||||
;; clearly is. It seems to not handle cl-defun, even though its code
|
||||
;; appears to account for it.
|
||||
(declare-function org-ql-search "org-ql-search" t)
|
||||
(declare-function org-ql-search--org-link-store-props "org-ql-search" t)
|
||||
|
||||
(require 'dash)
|
||||
(require 's)
|
||||
|
|
@ -153,11 +151,11 @@ See info node `(elisp)Cyclic Window Ordering'."
|
|||
(interactive)
|
||||
(let* ((ts (ts-now))
|
||||
(beg-of-week (->> ts
|
||||
(ts-adjust 'day (- (ts-dow (ts-now))))
|
||||
(ts-apply :hour 0 :minute 0 :second 0)))
|
||||
(ts-adjust 'day (- (ts-dow (ts-now))))
|
||||
(ts-apply :hour 0 :minute 0 :second 0)))
|
||||
(end-of-week (->> ts
|
||||
(ts-adjust 'day (- 6 (ts-dow (ts-now))))
|
||||
(ts-apply :hour 23 :minute 59 :second 59))))
|
||||
(ts-adjust 'day (- 6 (ts-dow (ts-now))))
|
||||
(ts-apply :hour 23 :minute 59 :second 59))))
|
||||
(org-ql-search (org-agenda-files)
|
||||
`(ts-active :from ,beg-of-week
|
||||
:to ,end-of-week)
|
||||
|
|
@ -170,11 +168,11 @@ See info node `(elisp)Cyclic Window Ordering'."
|
|||
(interactive)
|
||||
(let* ((ts (ts-adjust 'day 7 (ts-now)))
|
||||
(beg-of-week (->> ts
|
||||
(ts-adjust 'day (- (ts-dow (ts-now))))
|
||||
(ts-apply :hour 0 :minute 0 :second 0)))
|
||||
(ts-adjust 'day (- (ts-dow (ts-now))))
|
||||
(ts-apply :hour 0 :minute 0 :second 0)))
|
||||
(end-of-week (->> ts
|
||||
(ts-adjust 'day (- 6 (ts-dow (ts-now))))
|
||||
(ts-apply :hour 23 :minute 59 :second 59))))
|
||||
(ts-adjust 'day (- 6 (ts-dow (ts-now))))
|
||||
(ts-apply :hour 23 :minute 59 :second 59))))
|
||||
(org-ql-search (org-agenda-files)
|
||||
`(ts-active :from ,beg-of-week
|
||||
:to ,end-of-week)
|
||||
|
|
@ -272,8 +270,8 @@ TYPE may be `ts', `ts-active', `ts-inactive', `clocked', or
|
|||
`closed'."
|
||||
(interactive (list :num-days (read-number "Days: ")
|
||||
:type (->> '(ts ts-active ts-inactive clocked closed)
|
||||
(completing-read "Timestamp type: ")
|
||||
intern)))
|
||||
(completing-read "Timestamp type: ")
|
||||
intern)))
|
||||
;; It doesn't make much sense to use other date-based selectors to
|
||||
;; look into the past, so to prevent confusion, we won't allow them.
|
||||
(-let* ((query (pcase-exhaustive type
|
||||
|
|
@ -288,7 +286,8 @@ TYPE may be `ts', `ts-active', `ts-inactive', `clocked', or
|
|||
|
||||
;;;###autoload
|
||||
(cl-defun org-ql-view-sidebar (&key (slot org-ql-view-list-slot))
|
||||
"Show `org-ql-view' view list sidebar."
|
||||
"Show `org-ql-view' view list sidebar.
|
||||
SLOT is passed to `display-buffer-in-side-window', which see."
|
||||
;; TODO: Update sidebar when `org-ql-views' changes.
|
||||
(interactive)
|
||||
(select-window
|
||||
|
|
@ -353,7 +352,8 @@ update search arguments."
|
|||
(yes-or-no-p (format "Overwrite view \"%s\"?" name)))
|
||||
(setf (map-elt org-ql-views name nil #'equal) plist)
|
||||
(customize-set-variable 'org-ql-views org-ql-views)
|
||||
(customize-mark-to-save 'org-ql-views))))
|
||||
(customize-mark-to-save 'org-ql-views)
|
||||
(custom-save-all))))
|
||||
|
||||
(defun org-ql-view-delete ()
|
||||
"Delete current view (with confirmation)."
|
||||
|
|
@ -363,7 +363,8 @@ update search arguments."
|
|||
(--remove (equal (car it) org-ql-view-title)
|
||||
org-ql-views))
|
||||
(customize-set-variable 'org-ql-views org-ql-views)
|
||||
(customize-mark-to-save 'org-ql-views)))
|
||||
(customize-mark-to-save 'org-ql-views)
|
||||
(custom-save-all)))
|
||||
|
||||
(defun org-ql-view-customize ()
|
||||
"Customize view at point in `org-ql-view-sidebar' buffer."
|
||||
|
|
@ -395,12 +396,12 @@ update search arguments."
|
|||
(let ((inhibit-read-only t))
|
||||
(erase-buffer)
|
||||
(->> org-ql-views
|
||||
(-map #'car)
|
||||
(-sort (if org-ql-view-sidebar-sort-views
|
||||
#'string<
|
||||
#'ignore))
|
||||
(s-join "\n")
|
||||
insert))
|
||||
(-map #'car)
|
||||
(-sort (if org-ql-view-sidebar-sort-views
|
||||
#'string<
|
||||
#'ignore))
|
||||
(s-join "\n")
|
||||
insert))
|
||||
(current-buffer)))
|
||||
|
||||
(defvar bookmark-make-record-function)
|
||||
|
|
@ -469,8 +470,8 @@ If TITLE, prepend it to the header."
|
|||
(format "%s" (org-ql-view--contract-buffers-files buffers-files))))
|
||||
(buffers-files-formatted (when buffers-files-formatted
|
||||
(propertize (->> buffers-files-formatted
|
||||
(org-ql-view--font-lock-string 'emacs-lisp-mode)
|
||||
(s-truncate available-width))
|
||||
(org-ql-view--font-lock-string 'emacs-lisp-mode)
|
||||
(s-truncate available-width))
|
||||
'help-echo buffers-files-formatted))))
|
||||
(concat title
|
||||
(when query (propertize "Query:" 'face 'transient-argument))
|
||||
|
|
@ -672,7 +673,7 @@ When opened, the link searches the buffer it's opened from."
|
|||
(when (buffer-base-buffer thing)
|
||||
(buffer-file-name (buffer-base-buffer thing))))))))
|
||||
(unless (strings-or-file-buffers-p org-ql-view-buffers-files)
|
||||
(user-error "Views that search non-file-backed buffers can't be linked to"))
|
||||
(user-error "%s" "Views that search non-file-backed buffers can't be linked to"))
|
||||
(let* ((query-string (--if-let (org-ql--query-sexp-to-string org-ql-view-query)
|
||||
it (org-ql-view--format-query org-ql-view-query)))
|
||||
(buffers-files (prompt-for (org-ql-view--contract-buffers-files org-ql-view-buffers-files)))
|
||||
|
|
@ -688,8 +689,7 @@ When opened, the link searches the buffer it's opened from."
|
|||
"?" (url-build-query-string (delete nil params))))
|
||||
(url (url-recreate-url (url-parse-make-urlobj "org-ql-search" nil nil nil nil
|
||||
filename))))
|
||||
;; FIXME: "Warning: ‘org-store-link-props’ is an obsolete function (as of Org 9.3); use ‘org-link-store-props’ instead"
|
||||
(org-store-link-props
|
||||
(org-ql-search--org-link-store-props
|
||||
:type "org-ql-search"
|
||||
:link url
|
||||
:description (concat "org-ql-search: " org-ql-view-title))))
|
||||
|
|
@ -750,8 +750,8 @@ When opened, the link searches the buffer it's opened from."
|
|||
(s-truncate (- (window-width) 15)
|
||||
(concat (propertize key 'face 'transient-argument) ": "
|
||||
(->> value
|
||||
org-ql-view--format-query
|
||||
(org-ql-view--font-lock-string 'emacs-lisp-mode)))))
|
||||
org-ql-view--format-query
|
||||
(org-ql-view--font-lock-string 'emacs-lisp-mode)))))
|
||||
|
||||
(transient-define-infix org-ql-view--transient-title ()
|
||||
;; TODO: Add an asterisk or something when the view has been modified but not saved.
|
||||
|
|
@ -820,6 +820,20 @@ When opened, the link searches the buffer it's opened from."
|
|||
|
||||
;;;; Faces/properties
|
||||
|
||||
(defalias 'org-ql-view--resolve-element-properties
|
||||
;; It would be preferable to define this as an inline function, but
|
||||
;; that would mean that users would have to recompile org-ql when
|
||||
;; upgrading to Org 9.7 or else get weird errors.
|
||||
;; TODO(someday): Define `org-ql-view--resolve-element-properties' as inline.
|
||||
(if (version<= "9.7" org-version)
|
||||
(lambda (node)
|
||||
"Resolve NODE's properties using `org-element-properties-resolve'."
|
||||
;; Silence warnings about `org-element-properties-resolve'
|
||||
;; being unresolved on earlier Org versions.
|
||||
(with-no-warnings
|
||||
(org-element-properties-resolve node 'force-undefer)))
|
||||
#'identity))
|
||||
|
||||
(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.
|
||||
|
|
@ -829,6 +843,7 @@ returned by `org-element-parse-buffer'. If ELEMENT is nil,
|
|||
return an empty string."
|
||||
(if (not element)
|
||||
""
|
||||
(setf element (org-ql-view--resolve-element-properties element))
|
||||
(let* ((properties (cadr element))
|
||||
;; Remove the :parent property, which so bloats the size of
|
||||
;; the properties list that it makes it essentially
|
||||
|
|
@ -850,8 +865,8 @@ return an empty string."
|
|||
;; 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)))
|
||||
(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)))
|
||||
(tag-list (if org-use-tag-inheritance
|
||||
|
|
@ -866,15 +881,14 @@ return an empty string."
|
|||
(not type))
|
||||
append type)))
|
||||
;; No marker found
|
||||
;; TODO: Use `display-warning' with `org-ql' as the type.
|
||||
(warn "No marker found for item: %s" title)
|
||||
(display-warning 'org-ql (format "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))))
|
||||
(s-join ":" it)
|
||||
(s-wrap it ":")
|
||||
(org-add-props it nil 'face 'org-tag))))
|
||||
;; (category (org-element-property :category element))
|
||||
;; Org Agenda priorities are subtracted from `org-priority-lowest'
|
||||
;; and multiplied by 1000, so do the same here. Also assume that <65
|
||||
|
|
@ -890,7 +904,8 @@ return an empty string."
|
|||
(char-to-string)
|
||||
(format "[#%s]")
|
||||
(org-ql-view--add-priority-face)))
|
||||
(habit-property (org-with-point-at (org-element-property :begin element)
|
||||
(habit-property (org-with-point-at (or (org-element-property :org-hd-marker element)
|
||||
(org-element-property :org-marker element))
|
||||
(when (org-is-habit-p)
|
||||
(org-habit-parse-todo))))
|
||||
(due-string (pcase (org-element-property :relative-due-date element)
|
||||
|
|
@ -912,8 +927,8 @@ return an empty string."
|
|||
(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)))
|
||||
(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."
|
||||
|
|
@ -970,11 +985,11 @@ return an empty string."
|
|||
((> 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)))
|
||||
(org-add-props it nil
|
||||
'face face)))
|
||||
(properties (--> (cadr element)
|
||||
(plist-put it :title title)
|
||||
(plist-put it :relative-due-date relative-due-date))))
|
||||
(plist-put it :title title)
|
||||
(plist-put it :relative-due-date relative-due-date))))
|
||||
(list (car element)
|
||||
properties))
|
||||
;; Not scheduled
|
||||
|
|
@ -996,16 +1011,16 @@ property."
|
|||
;; 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)))
|
||||
(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)))
|
||||
(org-add-props it nil
|
||||
'face face)))
|
||||
(properties (--> (cadr element)
|
||||
(plist-put it :title title)
|
||||
(plist-put it :relative-due-date relative-due-date))))
|
||||
(plist-put it :title title)
|
||||
(plist-put it :relative-due-date relative-due-date))))
|
||||
(list (car element)
|
||||
properties))
|
||||
;; No deadline
|
||||
|
|
@ -1024,10 +1039,6 @@ property."
|
|||
;; These functions are somewhat regrettable because of the need to keep them
|
||||
;; in sync, but it seems worth it to provide users with the flexibility.
|
||||
|
||||
;; FIXME: `check-declare' declares that this function is not in org-ql-search, even though
|
||||
;; it is. It appears to happen because `org-ql-search-directories-files' is declared with
|
||||
;; `cl-defun', because when I remove "cl-", it finds it. This makes no sense, because the
|
||||
;; source code of `check-declare' shows that it searches for "cl-defun" declarations.
|
||||
(declare-function org-ql-search-directories-files "org-ql-search" t)
|
||||
|
||||
(defun org-ql-view--contract-buffers-files (buffers-files)
|
||||
|
|
@ -1128,7 +1139,7 @@ The counterpart to `org-ql-view--contract-buffers-files'."
|
|||
"todo")
|
||||
nil nil (when org-ql-view-sort
|
||||
(prin1-to-string org-ql-view-sort)))
|
||||
(--remove (equal "buffer-order" it)))))
|
||||
(--remove (equal "buffer-order" it)))))
|
||||
(pcase input
|
||||
('nil nil)
|
||||
((and (pred listp) sort)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue