WIP

org-ql.el

@@ -164,6 +164,7 @@ See Info node `(org-ql)Queries'."
 
 (defun org-ql--define-normalizers (normalizers)
   "FIXME"
+  (setf normalizers (mapcar #'car (delq nil normalizers)))
   (fset 'org-ql--normalize-query
         `(lambda (query)
            "FIXME"
@@ -178,23 +179,28 @@ See Info node `(org-ql)Queries'."
                                                                   ,@(mapcar #'rec clauses)))
                               ;; TODO: Combine (regexp) when appropriate (i.e. inside an OR, not an AND).
                               ((pred stringp) `(regexp ,element))
+
                               ,@normalizers
+
                               ;; Any other form: passed through unchanged.
                               (_ element))))
              (rec query)))))
 
-(defun org-ql--define-preambles (preambles)
+(defun org-ql--define-preamble-fn (predicates)
   "FIXME"
   ;; NOTE: I don't how the `list' symbol ends up in the list, but anyway...
-  (setf preambles (--map (pcase-let* ((`(,matcher ,props) it)
+  (let* ((preamble-patterns
-                                      (`(,_ . ,(map (:predicate predicate) (:regexp regexp) (:case-fold case-fold))) props))
+          (->> predicates
+               (--map (plist-get (cdr it) :preambles))
+               (-flatten-n 1)
+               (--map (pcase-let* ((`(,matcher ,(map (:predicate predicate) (:regexp regexp) (:case-fold case-fold)))
+                                    it))
                         `(,matcher
                           ,(when regexp
                              `(setq org-ql-preamble ,regexp))
                           (setq preamble-case-fold ,case-fold)
                           ;; NOTE: Even when `predicate' is nil, it must be returned in the pcase form.
-                             ',predicate))
+                          ',predicate))))))
-                         preambles))
     (fset 'org-ql--query-preamble-new
           `(lambda (query)
              "FIXME"
@@ -209,7 +215,7 @@ See Info node `(org-ql)Queries'."
                                          (pcase element
                                            (`(or _) element)
 
-                                         ,@preambles
+                                           ,@preamble-patterns
 
                                            ;; (`(clocked . ,_)
                                            ;;  (setq org-ql-preamble org-ql-clock-regexp)
@@ -226,9 +232,9 @@ See Info node `(org-ql)Queries'."
                                          `((or)))
                                      t)
                                     (query (-flatten-n 1 query))))
-                    (list :query query :preamble org-ql-preamble :preamble-case-fold preamble-case-fold))))))))
+                      (list :query query :preamble org-ql-preamble :preamble-case-fold preamble-case-fold)))))))))
 
-(cl-defmacro org-ql-define-predicate (name args docstring &key predicate preamble normalizer)
+(cl-defmacro org-ql-define-predicate (name args docstring &key predicate preambles normalizers)
   "Define an `org-ql' selector predicate named `org-ql--predicate-NAME'.
 NAME may be a symbol or a list of symbols: if a list, the first
 is used as the name and the rest are aliases.  ARGS is a
@@ -251,53 +257,26 @@ match."
          (fn-name (intern (concat "org-ql--predicate-" (symbol-name name))))
          (predicate-name (intern (symbol-name name)))
          (predicate-names (delq nil (cons predicate-name aliases)))
-         (normalizer (cl-sublis (list (cons 'predicate-names (cons 'or (--map (list 'quote it) predicate-names))))
+         (normalizers (cl-sublis (list (cons 'predicate-names (cons 'or (--map (list 'quote it) predicate-names))))
-                                normalizer))
+                                 normalizers))
-         (preamble (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)))
                                      (cons 'predicate predicate))
-                              preamble)))
+                               preambles)))
     `(progn
        (cl-eval-when (compile load eval)
 	 ;; When compiling, the predicate must be added to `org-ql-predicates' before `org-ql--def-plain-query-fn'
 	 ;; is called to define `org-ql--plain-query'.  Otherwise, `org-ql--plain-query' seems to work properly
 	 ;; when interpreted but not always when the file is byte-compiled.
          (setf (map-elt org-ql-predicate-list ',predicate-name)
-               ;; (list :aliases ',aliases :fn ',fn-name :docstring ,docstring :args ',args
-               ;;       :normalizer ',normalizer :preamble ',preamble)
                `(:aliases ,',aliases :fn ,',fn-name :docstring ,,docstring :args ,',args
-                          :normalizer ,',normalizer :preamble ,',preamble))
+                          :normalizers ,',normalizers :preambles ,',preambles))
          (unless org-ql-defpred-defer
-           (org-ql--define-normalizers (--map (plist-get it :normalizer) (mapcar #'cdr org-ql-predicate-list)))
+           (org-ql--define-normalizers (--map (plist-get it :normalizers) (mapcar #'cdr org-ql-predicate-list)))
-           (org-ql--define-preambles (--map (plist-get it :preamble) (mapcar #'cdr org-ql-predicate-list)))
+           ;; NOTE: Reversing is important!
+           (org-ql--define-preamble-fn (reverse org-ql-predicate-list))
            (org-ql--def-plain-query-fn)))
        (cl-defun ,fn-name ,args ,docstring ,predicate))))
 
-(org-ql-define-predicate (clocked c) (&key from to _on)
-  ;; NOTE: _on is pre-processed
-  "Return non-nil if current entry was clocked in given period.
-If no arguments are specified, return non-nil if entry has any
-timestamp.
-
-If FROM, return non-nil if entry has a timestamp on or after
-FROM.
-
-If TO, return non-nil if entry has a timestamp on or before TO.
-
-If ON, return non-nil if entry has a timestamp on date ON.
-
-FROM, TO, and ON should be either `ts' structs, or strings
-parseable by `parse-time-string' which may omit the time value."
-  :normalizer (`(,predicate-names
-                 ,(and num-days (pred numberp)))
-               ;; (clocked) and (closed) implicitly look into the past.
-               (let ((from (->> (ts-now)
-                                (ts-adjust 'day (* -1 num-days))
-                                (ts-apply :hour 0 :minute 0 :second 0))))
-                 `(clocked :from ,from)))
-  :preamble (`(,predicate-names . ,_)
-             (list :regexp org-ql-clock-regexp :predicate predicate :case-fold nil))
-  :predicate (org-ql--predicate-ts :from from :to to :regexp org-ql-clock-regexp :match-group 1))
-
 ;; TODO: Mark as obsolete/deprecated.
 ;;;###autoload
 (cl-defmacro org-ql (buffers-or-files query &key sort narrow action)
@@ -1196,42 +1175,84 @@ Arguments STRING, POS, FILL, and LEVEL are according to
 
 ;;;;; Predicates
 
-(org-ql--defpred category (&rest categories)
+(org-ql-define-predicate (clocked c) (&key from to _on)
+  ;; NOTE: _on is pre-processed
+  "Return non-nil if current entry was clocked in given period.
+If no arguments are specified, return non-nil if entry has any
+timestamp.
+
+If FROM, return non-nil if entry has a timestamp on or after
+FROM.
+
+If TO, return non-nil if entry has a timestamp on or before TO.
+
+If ON, return non-nil if entry has a timestamp on date ON.
+
+FROM, TO, and ON should be either `ts' structs, or strings
+parseable by `parse-time-string' which may omit the time value."
+  :normalizers ((`(,predicate-names
+                   ,(and num-days (pred numberp)))
+                 ;; (clocked) and (closed) implicitly look into the past.
+                 (let ((from (->> (ts-now)
+                                  (ts-adjust 'day (* -1 num-days))
+                                  (ts-apply :hour 0 :minute 0 :second 0))))
+                   `(clocked :from ,from))))
+  :preambles ((`(,predicate-names . ,_)
+               (:regexp org-ql-clock-regexp :predicate predicate :case-fold nil)))
+  :predicate (org-ql--predicate-ts :from from :to to :regexp org-ql-clock-regexp :match-group 1))
+
+(org-ql-define-predicate category (&rest categories)
   "Return non-nil if current heading is in one or more of CATEGORIES (a list of strings)."
-  (when-let ((category (org-get-category (point))))
+  :predicate (when-let ((category (org-get-category (point))))
                (cl-typecase categories
                  (null t)
                  (otherwise (member category categories)))))
 
-(org-ql--defpred path (&rest regexps)
+(org-ql-define-predicate path (&rest regexps)
   "Return non-nil if current heading's buffer's filename path matches any of REGEXPS (regexp strings).
 Without arguments, return non-nil if buffer is file-backed."
-  (when (buffer-file-name)
+  :predicate (when (buffer-file-name)
                (cl-typecase regexps
                  (null t)
                  (list (cl-loop for regexp in regexps
                                 thereis (string-match regexp (buffer-file-name)))))))
 
-(org-ql--defpred todo (&rest keywords)
+(org-ql-define-predicate todo (&rest keywords)
   "Return non-nil if current heading is a TODO item.
 With KEYWORDS, return non-nil if its keyword is one of KEYWORDS (a list of strings)."
-  (when-let ((state (org-get-todo-state)))
+  ;; TODO: Can we make a preamble for plain (todo) queries?
+  :preambles ((`(,predicate-names . ,(and todo-keywords (guard todo-keywords)))
+               (:case-fold nil :regexp (rx-to-string `(seq bol (1+ "*") (1+ space) (or ,@todo-keywords) (or " " eol)) t))))
+  :predicate (when-let ((state (org-get-todo-state)))
                (cl-typecase keywords
                  (null (not (member state org-done-keywords)))
                  (list (member state keywords))
                  (symbol (member state (symbol-value keywords)))
                  (otherwise (user-error "Invalid todo keywords: %s" keywords)))))
 
-(org-ql--defpred done ()
+(org-ql-define-predicate done ()
   "Return non-nil if entry's TODO keyword is in `org-done-keywords'."
   ;; NOTE: This was a defsubst before being defined with the macro.  Might be good to make it a defsubst again.
-  (or (apply #'org-ql--predicate-todo org-done-keywords)))
+  :predicate (or (apply #'org-ql--predicate-todo org-done-keywords)))
 
-(org-ql--defpred (tags tags-all tags&) (&rest tags)
+(org-ql-define-predicate (tags tags-all tags&) (&rest tags)
   ;; NOTE: tags-all and tags& are "virtual" predicates that are handled by query pre-processing.
   "Return non-nil if current heading has one or more of TAGS (a list of strings).
 Tests both inherited and local tags."
-  (cl-macrolet ((tags-p (tags)
+  :normalizers ((`(,predicate-names . ,tags) `(and ,@(--map `(tags ,it) tags)))
+                ;; MAYBE: -all versions for inherited and local.
+                ;; Inherited and local predicate aliases.
+
+
+
+                )
+  :preambles ((`(,predicate-names . ,tags)
+               ;; When searching for local, non-inherited tags, we can
+               ;; search directly to headings containing one of the tags.
+               (:regexp (rx-to-string `(seq bol (1+ "*") (1+ space) (1+ not-newline)
+                                            ":" (or ,@tags) ":")
+                                      t))))
+  :predicate (cl-macrolet ((tags-p (tags)
                                    `(and ,tags
                                          (not (eq 'org-ql-nil ,tags)))))
                (-let* (((inherited local) (org-ql--tags-at (point))))
@@ -1243,9 +1264,7 @@ Tests both inherited and local tags."
                                   (when (tags-p local)
                                     (seq-intersection tags local))))))))
 
-;; MAYBE: Preambles for outline-path predicates.  Not sure if possible without complicated logic.
+(org-ql-define-predicate (outline-path olp) (&rest regexps)
-
-(org-ql--defpred (outline-path olp) (&rest regexps)
   "Return non-nil if current node's outline path matches all of REGEXPS.
 Each string is compared as a regexp to each element of the node's
 outline path with `string-match'.  For example, if an entry's
@@ -1257,11 +1276,14 @@ the following queries:
   (olp \"Food\" \"Fruits\")
   (olp \"Fruits\" \"Grapes\")
   (olp \"Food\" \"Grapes\")"
-  (let ((entry-olp (org-ql--value-at (point) #'org-ql--outline-path)))
+  :normalizers ((`(,predicate-names . ,strings)
+                 ;; Regexp quote headings.
+                 `(outline-path ,@(mapcar #'regexp-quote strings))))
+  :predicate (let ((entry-olp (org-ql--value-at (point) #'org-ql--outline-path)))
                (cl-loop for h in regexps
                         always (cl-member h entry-olp :test #'string-match))))
 
-(org-ql--defpred (outline-path-segment olps) (&rest regexps)
+(org-ql-define-predicate (outline-path-segment olps) (&rest regexps)
   "Return non-nil if current node's outline path matches segment REGEXPS.
 Matches REGEXPS as a contiguous segment of the outline path.
 Each regexp is compared to each element of the node's outline
@@ -1279,12 +1301,17 @@ contiguous segment of the outline path:
 
   (olp \"Food\" \"Grape\")"
   ;; MAYBE: Allow anchored matching.
-  (org-ql--infix-p regexps (org-ql--value-at (point) #'org-ql--outline-path)))
+  :normalizers ((`(,(or 'outline-path-segment 'olps) . ,strings)
+                 ;; Regexp quote headings.
+                 `(outline-path-segment ,@(mapcar #'regexp-quote strings))))
+  :predicate (org-ql--infix-p regexps (org-ql--value-at (point) #'org-ql--outline-path)))
 
-(org-ql--defpred (tags-inherited tags-i itags) (&rest tags)
+(org-ql-define-predicate (tags-inherited tags-i itags) (&rest tags)
   "Return non-nil if current heading's inherited tags include one or more of TAGS (a list of strings).
 If TAGS is nil, return non-nil if heading has any inherited tags."
-  (cl-macrolet ((tags-p (tags)
+  :normalizers ((`(,predicate-names . ,tags)
+                 `(tags-inherited ,@tags)))
+  :predicate (cl-macrolet ((tags-p (tags)
                                    `(and ,tags
                                          (not (eq 'org-ql-nil ,tags)))))
                (-let* (((inherited _) (org-ql--tags-at (point))))
@@ -1293,10 +1320,17 @@ If TAGS is nil, return non-nil if heading has any inherited tags."
                    (otherwise (when (tags-p inherited)
                                 (seq-intersection tags inherited)))))))
 
-(org-ql--defpred (tags-local tags-l ltags) (&rest tags)
+(org-ql-define-predicate (tags-local tags-l ltags) (&rest tags)
   "Return non-nil if current heading's local tags include one or more of TAGS (a list of strings).
 If TAGS is nil, return non-nil if heading has any local tags."
-  (cl-macrolet ((tags-p (tags)
+  :normalizers ((`(,predicate-names . ,tags) `(tags-local ,@tags)))
+  :preambles ((`(,predicate-names . ,tags)
+               ;; When searching for local, non-inherited tags, we can
+               ;; search directly to headings containing one of the tags.
+               (:regexp (rx-to-string `(seq bol (1+ "*") (1+ space) (1+ not-newline)
+                                            ":" (or ,@tags) ":")
+                                      t))))
+  :predicate (cl-macrolet ((tags-p (tags)
                                    `(and ,tags
                                          (not (eq 'org-ql-nil ,tags)))))
                (-let* (((_ local) (org-ql--tags-at (point))))
@@ -1305,10 +1339,12 @@ If TAGS is nil, return non-nil if heading has any local tags."
                    (otherwise (when (tags-p local)
                                 (seq-intersection tags local)))))))
 
-(org-ql--defpred (tags-regexp tags*) (&rest regexps)
+(org-ql-define-predicate (tags-regexp tags*) (&rest regexps)
   "Return non-nil if current heading has tags matching one or more of REGEXPS.
 Tests both inherited and local tags."
-  (cl-macrolet ((tags-p (tags)
+  :normalizers ((`(,predicate-names . ,regexps)
+                 `(tags-regexp ,@regexps)))
+  :predicate (cl-macrolet ((tags-p (tags)
                                    `(and ,tags
                                          (not (eq 'org-ql-nil ,tags)))))
                (-let* (((inherited local) (org-ql--tags-at (point))))
@@ -1324,7 +1360,7 @@ Tests both inherited and local tags."
                                              thereis (cl-loop for regexp in regexps
                                                               thereis (string-match regexp tag))))))))))
 
-(org-ql--defpred level (level-or-comparator &optional level)
+(org-ql-define-predicate level (level-or-comparator &optional level)
   "Return non-nil if current heading's outline level matches arguments.
 The following forms are accepted:
 
@@ -1333,9 +1369,27 @@ The following forms are accepted:
   (level COMPARATOR NUMBER): Matches if heading level compares to NUMBER with COMPARATOR.
 
 COMPARATOR may be `<', `<=', `>', or `>='."
+  :normalizers ((`(,predicate-names . ,args)
+                 ;; Arguments could be given as strings (e.g. from a non-Lisp query).
+                 `(level ,@(--map (pcase it
+                                    ((or "<" "<=" ">" ">=" "=")
+                                     (intern it))
+                                    ((pred stringp) (string-to-number it))
+                                    (_ it))
+                                  args))))
+  :preambles ((`(,predicate-names ,comparator-or-num ,num)
+               (let ((repeat (pcase comparator-or-num
+                               ('< `(repeat 1 ,(1- num) "*"))
+                               ('<= `(repeat 1 ,num "*"))
+                               ('> `(>= ,(1+ num) "*"))
+                               ('>= `(>= ,num "*"))
+                               ((pred integerp) `(repeat ,comparator-or-num ,num "*")))))
+                 (:regexp (rx-to-string `(seq bol ,repeat " ") t))))
+              (`(,predicate-names ,num)
+               (:regexp (rx-to-string `(seq bol (repeat ,num "*") " ") t))))
   ;; NOTE: It might be necessary to take into account `org-odd-levels'; see docstring for
   ;; `org-outline-level'.
-  (when-let ((outline-level (org-outline-level)))
+  :predicate (when-let ((outline-level (org-outline-level)))
                (pcase level-or-comparator
                  ((pred numberp) (pcase level
                                    ('nil ;; Equality
@@ -1345,6 +1399,10 @@ COMPARATOR may be `<', `<=', `>', or `>='."
                  ((pred symbolp) ;; Compare with function
                   (funcall level-or-comparator outline-level level)))))
 
+;;;;;; Old definitions
+
+;; MAYBE: Preambles for outline-path predicates.  Not sure if possible without complicated logic.
+
 (org-ql--defpred link (&rest args)
   ;; User-facing argument form: (&optional description-or-target &key description target regexp-p).
   "Return non-nil if current heading contains a link matching arguments.