jiri/org-ql
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

More

Browse source
This commit is contained in:
Adam Porter 2017-08-05 04:48:06 -05:00
parent 4f81c672ff
commit 3b871552bd
1 changed files with 65 additions and 38 deletions
Download patch file Download diff file Expand all files Collapse all files

103
org-agenda-ng.el
View file

@ -19,42 +19,59 @@
;;;; Commands ;;;; Commands
(cl-defun org-agenda-ng--agenda (&key match-fns) (cl-defun org-agenda-ng--agenda (&key match-fns filter-fns)
(with-current-buffer (find-buffer-visiting "~/org/main.org") (let* ((tree (cddr (org-element-parse-buffer 'headline)))
(let* ((tree (cddr (org-element-parse-buffer 'headline))) (entries (--> (org-agenda-ng--filter-tree tree :match-fns match-fns :filter-fns filter-fns)
(entries (--> (org-agenda-ng--filter-tree tree :match-fns match-fns) (mapcar #'org-agenda-ng--format-element it)))
(mapcar #'org-agenda-ng--format-element it))) (result-string (org-agenda-finalize-entries entries 'agenda))
(result-string (org-agenda-finalize-entries entries 'agenda)) (target-buffer (get-buffer-create "test-agenda-ng")))
(target-buffer (get-buffer-create "test-agenda-ng"))) (with-current-buffer target-buffer
(with-current-buffer target-buffer (read-only-mode -1)
(read-only-mode -1) (erase-buffer)
(erase-buffer) (insert result-string)
(insert result-string) (read-only-mode 1)
(read-only-mode 1) (pop-to-buffer (current-buffer)))))
(pop-to-buffer (current-buffer))))))
(defmacro org-agenda-ng--test (&rest args)
`(with-current-buffer (find-buffer-visiting "~/org/main.org")
(org-agenda-ng--agenda
,@args)))
(defun org-agenda-ng--test-agenda () (defun org-agenda-ng--test-agenda ()
(interactive) (interactive)
(org-agenda-ng--agenda (org-agenda-ng--test
:match-fns '((org-agenda-ng--todo-p "TODO") :match-fns '((org-agenda-ng--todo-p "TODO")
(org-agenda-ng--date-p :deadline < "2017-08-05")))) (org-agenda-ng--date-p :deadline < "2017-08-05"))))
(defun org-agenda-ng--todo-list () (defun org-agenda-ng--test-agenda-today ()
(interactive) (interactive)
(org-agenda-ng--agenda (org-agenda-ng--test
:match-fns '((org-agenda-ng--todo-p "TODO")))) :match-fns `((org-agenda-ng--date-p :deadline <= ,(org-today))
(org-agenda-ng--date-p :scheduled <= ,(org-today)))
:filter-fns `((org-agenda-ng--todo-p ,org-done-keywords))))
(defun org-agenda-ng--test-todo-list ()
(interactive)
(org-agenda-ng--test
:match-fns '(org-agenda-ng--todo-p)
:filter-fns `((org-agenda-ng--todo-p ,org-done-keywords))))
;;;; Functions ;;;; Functions
(defun org-agenda-ng--filter-tree (tree &key match-fns) (cl-defun org-agenda-ng--filter-tree (tree &key match-fns filter-fns)
(let* ((types '(headline)) (let* ((types '(headline))
(info nil) (info nil)
(first-match nil) (first-match nil)
(fun (lambda (element) (fun (lambda (element)
(when (--all? (cl-typecase it (when (and (--any? (cl-typecase it
(function (funcall it element)) (function (funcall it element))
(cons (apply (car it) element (cdr it)))) (cons (apply (car it) element (cdr it))))
match-fns) match-fns)
(or (null filter-fns)
(--none? (cl-typecase it
(function (funcall it element))
(cons (apply (car it) element (cdr it))))
filter-fns)))
element)))) element))))
(org-element-map tree types fun info first-match))) (org-element-map tree types fun info first-match)))
@ -126,32 +143,42 @@ Its property list should be the second item in the list, as returned by `org-ele
;;;; Predicates ;;;; Predicates
(defun org-agenda-ng--todo-p (element &optional keyword) (defun org-agenda-ng--todo-p (element &optional keywords)
"Return non-nil if ELEMENT is a TODO item. "Return non-nil if ELEMENT is a TODO item.
With KEYWORD, return non-nil if it has the same TODO keyword." With KEYWORDS, return non-nil if its keyword is one of KEYWORDS."
(when-let ((element-keyword (org-element-property :todo-keyword element))) (when-let ((element-keyword (org-element-property :todo-keyword element)))
(pcase keyword (pcase keywords
('nil t) ('nil t)
((pred stringp) ((pred stringp)
(string= element-keyword keyword)) (string= element-keyword keywords))
((pred listp)
(member element-keyword keywords))
(otherwise (error "Invalid keyword argument: %s" otherwise))))) (otherwise (error "Invalid keyword argument: %s" otherwise)))))
(defun org-agenda-ng--date-p (entry type &optional comparator target-date) (defun org-agenda-ng--date-p (entry type &optional comparator target-date)
"Return non-nil if ENTRY has a date property of TYPE. "Return non-nil if ENTRY has a date property of TYPE.
TYPE should be a keyword symbol, like :scheduled or :deadline. TYPE should be a keyword symbol, like :scheduled or :deadline.
With COMPARATOR and DATE, return non-nil if entry's scheduled
date compares with TARGET-DATE according to COMPARATOR." With COMPARATOR and TARGET-DATE, return non-nil if entry's
scheduled date compares with TARGET-DATE according to COMPARATOR.
TARGET-DATE may be a string like \"2017-08-05\", or an integer
like one returned by `date-to-day'."
(when-let ((entry-date (org-element-property type entry))) (when-let ((entry-date (org-element-property type entry)))
;; Append time to target-date because `date-to-day' requires it
(setq target-date (concat target-date " 00:00"))
(setq target-day-number (date-to-day target-date))
(pcase comparator (pcase comparator
;; Not comparing, just checking if it has one
('nil t) ('nil t)
((and (pred functionp) (guard target-day-number)) ;; Compare dates
(pcase (org-element-property :type entry-date) ((and (pred functionp) (guard target-date))
((or 'active 'inactive) (let ((target-day-number (cl-typecase target-date
(funcall comparator ;; Append time to target-date
(org-time-string-to-absolute ;; because `date-to-day' requires it
(org-element-timestamp-interpreter entry-date 'ignore)) (string (date-to-day (concat target-date " 00:00")))
target-day-number)))) (integer target-date))))
(pcase (org-element-property :type entry-date)
((or 'active 'inactive)
(funcall comparator
(org-time-string-to-absolute
(org-element-timestamp-interpreter entry-date 'ignore))
target-day-number))
(error "Unknown entry-date type: %s" (org-element-property :type entry-date)))))
(otherwise (error "COMPARATOR (%s) must be a function, and DATE (%s) must be a string" comparator target-date))))) (otherwise (error "COMPARATOR (%s) must be a function, and DATE (%s) must be a string" comparator target-date)))))