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

Use cl-letf to allow shorter function names in tests

Browse source
This commit is contained in:
Adam Porter 2018-01-03 08:12:54 -06:00
parent 0abe04b916
commit e25332b933
1 changed files with 26 additions and 48 deletions
Download patch file Download diff file Expand all files Collapse all files

74
org-agenda-ng.el
View file

@ -39,7 +39,15 @@
;;;; Macros ;;;; Macros
(defmacro org-agenda-ng--flet (fns &rest body)
(declare (indent defun))
`(cl-letf ,(cl-loop for (fn def) in fns
collect `((symbol-function ',fn)
,def))
,@body))
(cl-defun org-agenda-ng--test-lambda (&key all any none) (cl-defun org-agenda-ng--test-lambda (&key all any none)
;; Not actually a macro, but...
`(lambda () `(lambda ()
(and ,@(-non-nil (list (when all (and ,@(-non-nil (list (when all
`(and ,@(--map (cl-typecase it `(and ,@(--map (cl-typecase it
@ -156,15 +164,6 @@
;;;; Functions ;;;; Functions
;; (cl-defun org-agenda-ng--get-entries (file &key any-preds none-preds)
;; "Return list of entries from FILE."
;; (with-current-buffer (find-buffer-visiting file)
;; (let* ((org-use-tag-inheritance t)
;; (tree (cddr (org-element-parse-buffer 'headline)))
;; (entries (--> (org-agenda-ng--filter-tree tree :any any-preds :none none-preds)
;; (mapcar #'org-agenda-ng--format-element it))))
;; entries)))
(cl-defun org-agenda-ng--heading-positions (file) (cl-defun org-agenda-ng--heading-positions (file)
"Return list of heading positions in FILE." "Return list of heading positions in FILE."
(with-current-buffer (find-buffer-visiting file) (with-current-buffer (find-buffer-visiting file)
@ -175,49 +174,28 @@
collect (point) collect (point)
while (outline-next-heading))))) while (outline-next-heading)))))
;; (cl-defun org-agenda-ng--filter-buffer (&key any-preds none-preds)
;; "Return positions of matching headings in current buffer.
;; Headings should return non-nil for any ANY-PREDS and nil for all
;; NONE-PREDS."
;; (cl-flet ((pred () (and (--any? (cl-typecase it
;; (function (funcall it))
;; (cons (apply (car it) (cdr it))))
;; any-preds)
;; ;; Don't return if any filters match
;; (or (null none-preds)
;; (--none? (cl-typecase it
;; (function (funcall it))
;; (cons (apply (car it) (cdr it))))
;; none-preds)))))
;; (org-with-wide-buffer
;; (goto-char (point-min))
;; (when (org-before-first-heading-p)
;; (outline-next-heading))
;; (cl-loop when (pred)
;; collect (point)
;; while (outline-next-heading)))))
(cl-defun org-agenda-ng--filter-buffer (&key all any none pred) (cl-defun org-agenda-ng--filter-buffer (&key all any none pred)
"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
NONE-PREDS." NONE-PREDS."
;; NOTE: Build lambda so typecase doesn't run for every item (org-agenda-ng--flet ((date (lambda (&rest args) (apply #'org-agenda-ng--date-p args)))
(let* ((our-lambda (when (or all any none) (todo (lambda (&rest args) (apply #'org-agenda-ng--todo-p args))))
(org-agenda-ng--test-lambda :all all :any any :none none))) (let* ((our-lambda (when (or all any none)
(pred (cond ((and our-lambda pred) (org-agenda-ng--test-lambda :all all :any any :none none)))
(lambda () (pred (cond ((and our-lambda pred)
(and (funcall our-lambda) (lambda ()
(funcall pred)))) (and (funcall our-lambda)
(our-lambda our-lambda) (funcall pred))))
(pred pred) (our-lambda our-lambda)
(t (user-error "No tests given"))))) (pred pred)
(org-with-wide-buffer (t (user-error "No tests given")))))
(goto-char (point-min)) (org-with-wide-buffer
(when (org-before-first-heading-p) (goto-char (point-min))
(outline-next-heading)) (when (org-before-first-heading-p)
(cl-loop when (funcall pred) (outline-next-heading))
collect (point) (cl-loop when (funcall pred)
while (outline-next-heading))))) collect (point)
while (outline-next-heading))))))
;;;; Faces/properties ;;;; Faces/properties