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

Prune

Browse source
This commit is contained in:
Adam Porter 2018-01-03 11:14:03 -06:00
parent c412012100
commit 1976319ed8
1 changed files with 12 additions and 102 deletions
Download patch file Download diff file Expand all files Collapse all files

114
org-agenda-ng.el
View file

@ -47,96 +47,15 @@
(symbol-function ,target))) (symbol-function ,target)))
,@body)) ,@body))
(cl-defun org-agenda-ng--test-lambda (&key all any none) (cl-defmacro org-agenda-ng (files &rest pred-body)
;; Not actually a macro, but...
`(lambda ()
(and ,@(-non-nil (list (when all
`(and ,@(--map (cl-typecase it
(function (list it))
(cons `(apply #',(car it) ',(cdr it))))
all)))
(when any
`(or ,@(--map (cl-typecase it
(function (list it))
(cons `(apply #',(car it) ',(cdr it))))
any)))
(when none
`(not (or ,@(--map (cl-typecase it
(function (list it))
(cons `(apply #',(car it) ',(cdr it))))
none)))))))))
(cl-defmacro org-agenda-ng (files &rest pred)
(declare (indent defun)) (declare (indent defun))
`(org-agenda-ng--agenda :files ,files `(org-agenda-ng--agenda :files ,files
:pred (lambda () :pred (lambda ()
,@pred))) ,@pred-body)))
;;;; Tests
(defun org-agenda-ng--test-test.org (&rest args)
;; Helper function
(apply #'org-agenda-ng--agenda :files '("~/src/emacs/org-super-agenda/test/test.org")
args))
(defun org-agenda-ng--test-agenda ()
(interactive)
(org-agenda-ng--test-test.org
:any '((org-agenda-ng--todo-p "TODO")
(org-agenda-ng--date-p :deadline < "2017-08-05"))))
(defun org-agenda-ng--test-agenda2 ()
(interactive)
(org-agenda-ng--test-test.org
:any `((org-agenda-ng--date-p :date <= ,(org-today))
(org-agenda-ng--date-p :deadline <= ,(+ org-deadline-warning-days (org-today)))
(org-agenda-ng--date-p :scheduled <= ,(org-today)))
:none `((org-agenda-ng--todo-p org-done-keywords))))
(defun org-agenda-ng--test-agenda3 ()
(interactive)
(org-agenda-ng--test-test.org
:any `((org-agenda-ng--date-p :date <= ,(org-today))
(org-agenda-ng--date-p :deadline <= ,(+ org-deadline-warning-days (org-today)))
(org-agenda-ng--date-p :scheduled <= ,(org-today)))
:none `((org-agenda-ng--todo-p org-done-keywords))))
(defun org-agenda-ng--test-agenda-today ()
(interactive)
(org-agenda-ng--agenda
:files "~/src/emacs/org-super-agenda/test/test.org"
:any `((org-agenda-ng--date-p :date <= ,(org-today))
(org-agenda-ng--date-p :deadline <= ,(+ org-deadline-warning-days (org-today)))
(org-agenda-ng--date-p :scheduled <= ,(org-today)))
:none `((org-agenda-ng--todo-p org-done-keywords))))
(defun org-agenda-ng--test-agenda-today ()
(interactive)
(org-agenda-ng--agenda
:files "~/src/emacs/org-super-agenda/test/test.org"
:any `((org-agenda-ng--date-p :date <= ,(org-today))
(org-agenda-ng--date-p :deadline <= ,(+ org-deadline-warning-days (org-today)))
(org-agenda-ng--date-p :scheduled <= ,(org-today)))
:none `((org-agenda-ng--todo-p org-done-keywords))))
(defun org-agenda-ng--test-agenda-today ()
(interactive)
(org-agenda-ng--agenda
:files org-agenda-files
:any `((org-agenda-ng--date-p :date <= ,(org-today))
(org-agenda-ng--date-p :deadline <= ,(+ org-deadline-warning-days (org-today)))
(org-agenda-ng--date-p :scheduled <= ,(org-today)))
:none `((org-agenda-ng--todo-p org-done-keywords))))
(defun org-agenda-ng--test-todo-list ()
(interactive)
(org-agenda-ng--test-test.org
:any '(org-agenda-ng--todo-p)
:none '((org-agenda-ng--todo-p org-done-keywords))))
;;;; Commands ;;;; Commands
(cl-defun org-agenda-ng--agenda (&key files all any none pred) (cl-defun org-agenda-ng--agenda (&key files pred)
(unless files (unless files
(setq files (buffer-file-name (current-buffer)))) (setq files (buffer-file-name (current-buffer))))
(unless (listp files) (unless (listp files)
@ -150,7 +69,7 @@
;; position instead of returning a list of ;; position instead of returning a list of
;; positions and then having to go back ;; positions and then having to go back
;; and get the entries at each position. ;; and get the entries at each position.
(let* ((positions (org-agenda-ng--filter-buffer :all all :any any :none none :pred pred)) (let* ((positions (org-agenda-ng--filter-buffer :pred pred))
(elements (--map (org-with-point-at it (elements (--map (org-with-point-at it
(org-element-headline-parser (org-element-headline-parser
;; FIXME: This is a hack ;; FIXME: This is a hack
@ -182,7 +101,7 @@
collect (point) collect (point)
while (outline-next-heading))))) while (outline-next-heading)))))
(cl-defun org-agenda-ng--filter-buffer (&key all any none pred) (cl-defun org-agenda-ng--filter-buffer (&key pred)
;; TODO: Remove all, any, and none, and just use the predicate lambda. ;; TODO: Remove all, any, and none, and just use the predicate lambda.
"Return positions of matching headings in current buffer. "Return positions of matching headings in current buffer.
Headings should return non-nil for any ANY-PREDS and nil for all Headings should return non-nil for any ANY-PREDS and nil for all
@ -192,22 +111,13 @@ NONE-PREDS."
(habit #'org-agenda-ng--habit-p) (habit #'org-agenda-ng--habit-p)
(todo #'org-agenda-ng--todo-p) (todo #'org-agenda-ng--todo-p)
(tags #'org-agenda-ng--tags-p)) (tags #'org-agenda-ng--tags-p))
(let* ((our-lambda (when (or all any none) (org-with-wide-buffer
(org-agenda-ng--test-lambda :all all :any any :none none))) (goto-char (point-min))
(pred (cond ((and our-lambda pred) (when (org-before-first-heading-p)
(lambda () (outline-next-heading))
(and (funcall our-lambda) (cl-loop when (funcall pred)
(funcall pred)))) collect (point)
(our-lambda our-lambda) while (outline-next-heading)))))
(pred pred)
(t (user-error "No tests given")))))
(org-with-wide-buffer
(goto-char (point-min))
(when (org-before-first-heading-p)
(outline-next-heading))
(cl-loop when (funcall pred)
collect (point)
while (outline-next-heading))))))
;;;; Faces/properties ;;;; Faces/properties