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

Change/Fix: Require peg 1.0, fix variable binding depth errors

Browse source 
Had to (and needed to, anyway) use peg-1.0.  And while this does less
macro magic, and less magic with cl-eval-when, I couldn't get around
using eval.  I wish peg had a function that takes a list of rules and
returns a predicate that matches a string or at point.  (I tried to
work around the lack of that by using parts of peg macros, but it's
very complicated, and everything I tried had one problem or another.)
This commit is contained in:
Adam Porter 2020-11-24 11:20:59 -06:00
parent 890c24786a
commit 014d49f416
3 changed files with 101 additions and 113 deletions
Download patch file Download diff file Expand all files Collapse all files

1
README.org
View file

@ -524,6 +524,7 @@ Simple links may also be written manually in either sexp or non-sexp form, like:
*Internal* *Internal*
+ Predicates are now defined more cleanly with a macro (=org-ql-defpred=) that consolidates functionality related to each predicate. This will also allow users to more easily define custom predicates. + Predicates are now defined more cleanly with a macro (=org-ql-defpred=) that consolidates functionality related to each predicate. This will also allow users to more easily define custom predicates.
+ Version 1.0 of library ~peg~ is now required.
** 0.5 ** 0.5

166
org-ql.el
View file

@ -3,7 +3,7 @@
;; Author: Adam Porter <adam@alphapapa.net> ;; Author: Adam Porter <adam@alphapapa.net>
;; Url: https://github.com/alphapapa/org-ql ;; Url: https://github.com/alphapapa/org-ql
;; Version: 0.6-pre ;; Version: 0.6-pre
;; Package-Requires: ((emacs "26.1") (dash "2.13") (dash-functional "1.2.0") (f "0.17.2") (map "2.1") (org "9.0") (org-super-agenda "1.2") (ov "1.0.6") (peg "0.6") (s "1.12.0") (transient "0.1") (ts "0.2-pre")) ;; Package-Requires: ((emacs "26.1") (dash "2.13") (dash-functional "1.2.0") (f "0.17.2") (map "2.1") (org "9.0") (org-super-agenda "1.2") (ov "1.0.6") (peg "1.0") (s "1.12.0") (transient "0.1") (ts "0.2-pre"))
;; Keywords: hypermedia, outlines, Org, agenda ;; Keywords: hypermedia, outlines, Org, agenda
;;; Commentary: ;;; Commentary:
@ -671,88 +671,76 @@ Arguments STRING, POS, FILL, and LEVEL are according to
(require 'peg) (require 'peg)
;; Fix compiler warnings probably caused by `peg' not using lexical-binding. (defun org-ql--def-query-string-to-sexp-fn (predicates)
;; TODO: File bug report upstream. "Define function `org-ql--query-string-to-sexp' according to PREDICATES.
(defvar peg-errors nil) Builds the PEG expression using PREDICATES (which should be the
(defvar peg-stack nil) value of `org-ql-predicates')."
(let* ((names (--map (symbol-name (plist-get (cdr it) :name))
(defmacro org-ql--peg-parse-string (rules string &optional noerror) predicates))
"Parse STRING according to RULES." (aliases (->> predicates
;; This sentence was in the docstring but Checkdoc is complaining, (--map (plist-get (cdr it) :aliases))
;; so moving it to a comment: "If NOERROR is non-nil, push nil -non-nil
;; resp. t if the parse failed resp. succeded instead of signaling -flatten
;; an error." (-map #'symbol-name)))
(predicate-names (->> (append names aliases)
;; Unfortunately, this macro was moved to peg-tests.el, so we copy it here. -uniq
`(with-temp-buffer ;; Sort the keywords longest-first to work around what seems to be an
(insert ,string) ;; obscure bug in `peg': when one keyword is a substring of another,
(goto-char (point-min)) ;; and the shorter one is listed first, the shorter one fails to match.
,(if noerror (-sort (-on #'> #'length))))
(let ((entry (make-symbol "entry")) (pexs `((query (+ term
(start (caar rules))) (opt (+ (syntax-class whitespace) (any)))))
`(peg-parse (,entry (or (and ,start `(-- t)) "")) (term (or (and negation (list positive-term)
. ,rules)) ;; This is a bit confusing, but it seems to work. There's probably a better way.
`(peg-parse . ,rules)))) `(pred -- (list 'not (car pred))))
positive-term))
(cl-eval-when (compile load eval) (positive-term (or (and predicate-with-args `(pred args -- (cons (intern pred) args)))
;; This `eval-when' is necessary, otherwise the macro does not define (and predicate-without-args `(pred -- (list (intern pred))))
;; the function correctly, apparently because `org-ql-predicates' (and plain-string `(s -- (list 'regexp s)))))
;; ends up being not defined correctly at expansion time. (plain-string (or quoted-arg unquoted-arg))
(predicate-with-args (substring predicate) ":" args)
(defun org-ql--def-query-string-to-sexp-fn (predicates) (predicate-without-args (substring predicate) ":")
"Define function `org-ql--query-string-to-sexp' according to PREDICATES. (predicate (or ,@predicate-names))
Builds the PEG expression using PREDICATES (which should be the (args (list (+ (and (or keyword-arg quoted-arg unquoted-arg) (opt separator)))))
value of `org-ql-predicates')." (keyword-arg (and keyword "=" `(kw -- (intern (concat ":" kw)))))
(let* ((names (--map (symbol-name (plist-get (cdr it) :name)) (keyword (substring (+ (not (or separator "=" "\"" (syntax-class whitespace))) (any))))
predicates)) (quoted-arg "\"" (substring (+ (not (or separator "\"")) (any))) "\"")
(aliases (->> predicates (unquoted-arg (substring (+ (not (or separator "\"" (syntax-class whitespace))) (any))))
(--map (plist-get (cdr it) :aliases)) (negation "!")
-non-nil (separator "," )))
-flatten (closure (lambda (input &optional boolean)
(-map #'symbol-name))) "Return query parsed from plain query string INPUT.
(predicates (->> (append names aliases) Multiple predicate-names are combined with BOOLEAN (default: `and')."
-uniq ;; HACK: Silence unused lexical variable warnings.
;; Sort the keywords longest-first to work around what seems to be an (ignore predicates predicate-names names aliases)
;; obscure bug in `peg': when one keyword is a substring of another, (unless (s-blank-str? input)
;; and the shorter one is listed first, the shorter one fails to match. (let* ((boolean (or boolean 'and))
(-sort (-on #'> #'length))))) (parsed-sexp
(fset 'org-ql--query-string-to-sexp (with-temp-buffer
(byte-compile (insert input)
`(cl-function (goto-char (point-min))
(lambda (input &optional (boolean 'and)) ;; Copied from `peg-parse'. There is no function in `peg' that
"Return query parsed from plain query string INPUT. ;; returns a matcher function--every entry point is a macro,
Multiple predicates are combined with BOOLEAN." ;; which means that, since we define our PEG rules at runtime when
(unless (s-blank-str? input) ;; predicate-names are defined, we either have to use `eval', or we
(let* ((query (org-ql--peg-parse-string ;; have to borrow some code. It ends up that we only have to
((query (+ term ;; borrow this `with-peg-rules' call, which isn't too bad.
(opt (+ (syntax-class whitespace) (any))))) (eval `(with-peg-rules ,pexs
(term (or (and negation (list positive-term) (peg-run (peg ,(caar pexs)) #'peg-signal-failure)))
;; This is a bit confusing, but it seems to work. There's probably a better way. )))
`(pred -- (list 'not (car pred)))) (pcase parsed-sexp
positive-term)) (`(,one-predicate) one-predicate)
(positive-term (or (and predicate-with-args `(pred args -- (cons (intern pred) args))) (`(,_ . ,_) (cons boolean (reverse parsed-sexp)))
(and predicate-without-args `(pred -- (list (intern pred)))) (_ nil)))))))
(and plain-string `(s -- (list 'regexp s))))) (fset 'org-ql--query-string-to-sexp closure)))
(plain-string (or quoted-arg unquoted-arg))
(predicate-with-args (substring predicate) ":" args)
(predicate-without-args (substring predicate) ":")
(predicate (or ,@predicates))
(args (list (+ (and (or keyword-arg quoted-arg unquoted-arg) (opt separator)))))
(keyword-arg (and keyword "=" `(kw -- (intern (concat ":" kw)))))
(keyword (substring (+ (not (or separator "=" "\"" (syntax-class whitespace))) (any))))
(quoted-arg "\"" (substring (+ (not (or separator "\"")) (any))) "\"")
(unquoted-arg (substring (+ (not (or separator "\"" (syntax-class whitespace))) (any))))
(negation "!")
(separator "," ))
input 'noerror)))
;; Discard the t that `peg-parse-string' always returns as the first
;; element. I don't know what it means, but we don't want it.
(if (> (length (cdr query)) 1)
(cons boolean (nreverse (cdr query)))
(cadr query)))))))))))
;;;;; Predicate definition ;;;;; Predicate definition
;; HACK: These functions *will* be defined at runtime, so we silence
;; compiler warnings about them:
(declare-function org-ql--normalize-query "org-ql" (query) t)
(declare-function org-ql--query-preamble "org-ql" (query) t)
(defvar org-ql-defpred-defer nil (defvar org-ql-defpred-defer nil
"Defer expensive function redefinitions when defining predicates. "Defer expensive function redefinitions when defining predicates.
When non-nil, defining a predicate with `org-ql-defpred' does not When non-nil, defining a predicate with `org-ql-defpred' does not
@ -961,11 +949,10 @@ It would be expanded to:
(preambles (cl-sublis (list (cons 'predicate-names (cons 'or (--map (list 'quote it) predicate-names)))) (preambles (cl-sublis (list (cons 'predicate-names (cons 'or (--map (list 'quote it) predicate-names))))
preambles))) preambles)))
`(progn `(progn
(cl-eval-when (compile load eval) (cl-defun ,fn-name ,args ,docstring ,body)
(cl-defun ,fn-name ,args ,docstring ,body))
;; SOMEDAY: Use `map-elt' here, after map 2.1 can be automatically installed in CI sandbox... ;; SOMEDAY: Use `map-elt' here, after map 2.1 can be automatically installed in CI sandbox...
(setf (alist-get ',predicate-name org-ql-predicates) (setf (alist-get ',predicate-name org-ql-predicates)
`(:name ,',name :aliases ,',aliases :fn ,',fn-name :docstring ,,docstring :args ,',args `(:name ,',name :aliases ,',aliases :fn ,',fn-name :docstring ,(\, docstring) :args ,',args
:normalizers ,',normalizers :preambles ,',preambles)) :normalizers ,',normalizers :preambles ,',preambles))
(unless org-ql-defpred-defer (unless org-ql-defpred-defer
;; Reversing preserves the order in which predicates were defined. ;; Reversing preserves the order in which predicates were defined.
@ -1018,10 +1005,9 @@ predicates."
;;;;;; Predicates ;;;;;; Predicates
(cl-eval-when (compile load eval) ;; Improve load time by deferring the per-predicate preamble- and normalizer-function
;; Improve load time by deferring the per-predicate preamble- and normalizer-function ;; redefinitions until all of the predicates have been defined.
;; redefinitions until all of the predicates have been defined. (setf org-ql-defpred-defer t)
(setf org-ql-defpred-defer t))
(org-ql-defpred category (&rest categories) (org-ql-defpred category (&rest categories)
"Return non-nil if current heading is in one or more of CATEGORIES (a list of strings)." "Return non-nil if current heading is in one or more of CATEGORIES (a list of strings)."
@ -1836,10 +1822,10 @@ of the line after the heading."
(from (test-timestamps (ts<= from next-ts))) (from (test-timestamps (ts<= from next-ts)))
(to (test-timestamps (ts<= next-ts to))))))) (to (test-timestamps (ts<= next-ts to)))))))
;; Predicates defined: stop deferring and define normalizer and preamble functions now. ;; NOTE: Predicates defined: stop deferring and define normalizer and
;; preamble functions now. Reversing preserves the order in which
;; they were defined. Generally it shouldn't matter, but it might...
(setf org-ql-defpred-defer nil) (setf org-ql-defpred-defer nil)
;; Reversing preserves the order in which they were defined.
;; Generally it shouldn't matter, but it might...
(org-ql--define-normalize-query-fn (reverse org-ql-predicates)) (org-ql--define-normalize-query-fn (reverse org-ql-predicates))
(org-ql--define-query-preamble-fn (reverse org-ql-predicates)) (org-ql--define-query-preamble-fn (reverse org-ql-predicates))
(org-ql--def-query-string-to-sexp-fn (reverse org-ql-predicates)) (org-ql--def-query-string-to-sexp-fn (reverse org-ql-predicates))

47
org-ql.info
View file

@ -972,6 +972,7 @@ File: README.info, Node: 06-pre, Next: 05, Up: Changelog
(org-ql-defpred) that consolidates functionality related to each (org-ql-defpred) that consolidates functionality related to each
predicate. This will also allow users to more easily define custom predicate. This will also allow users to more easily define custom
predicates. predicates.
• Version 1.0 of library ‘peg’ is now required.
 
File: README.info, Node: 05, Next: 049, Prev: 06-pre, Up: Changelog File: README.info, Node: 05, Next: 049, Prev: 06-pre, Up: Changelog
@ -1487,29 +1488,29 @@ Node: Links33872
Node: Tips34559 Node: Tips34559
Node: Changelog34877 Node: Changelog34877
Node: 06-pre35573 Node: 06-pre35573
Node: 0536139 Node: 0536196
Node: 04937616 Node: 04937673
Node: 04837890 Node: 04837947
Node: 04738237 Node: 04738294
Node: 04638632 Node: 04638689
Node: 04539032 Node: 04539089
Node: 04439391 Node: 04439448
Node: 04339748 Node: 04339805
Node: 04239943 Node: 04240000
Node: 04140104 Node: 04140161
Node: 0440345 Node: 0440402
Node: 03244278 Node: 03244335
Node: 03144657 Node: 03144714
Node: 0344854 Node: 0344911
Node: 02347829 Node: 02347886
Node: 02248057 Node: 02248114
Node: 02148325 Node: 02148382
Node: 0248524 Node: 0248581
Node: 0152559 Node: 0152616
Node: Notes52660 Node: Notes52717
Node: Comparison with Org Agenda searches52822 Node: Comparison with Org Agenda searches52879
Node: org-sidebar53694 Node: org-sidebar53751
Node: License53973 Node: License54030
 
End Tag Table End Tag Table