emacs-orgmode@gnu.org archives
 help / color / mirror / code / Atom feed
* new tag query parser [3/5] -- the code and how to use it (code attached)
@ 2012-08-16  4:00 Christopher Genovese
  0 siblings, 0 replies; only message in thread
From: Christopher Genovese @ 2012-08-16  4:00 UTC (permalink / raw)
  To: emacs-orgmode


[-- Attachment #1.1: Type: text/plain, Size: 2075 bytes --]

* The code for my new tag/todo-query parser implementation is attached.
  1. org-tag-query-parse.el   -- the new parser implementation
  2. tag-query-tests.el       -- the ``try it'' interface and test suites

* Installing [fn:1]
  1. Put org-tag-query-parse.el on your load path (or add its location)
  2. Byte compile org-tag-query-parse.el but do *not* load it yet
  3. Load tag-query-tests.el or do (require 'tag-query-tests).

* Using it [fn:2]
  1. Run the tests with M-x run-tag-query-tests

     This runs the tests and nicely displays a summary in a new buffer.
     Give a prefix argument to display detailed test results instead,
     showing all the queries tested. All tests passed for me with
     GNU Emacs 23.2 and 24.1 on Mac OS X 10.7.3 and 10.6.8.

  2. Search with queries as usual.

     Do ordinary tag searches or use the mapping API via
     org-scan-tags and org-map-entries as you ordinarily would.

  3. Swap parsers with M-x org-use-tag-parser.

     This toggles between new and original parser implementations.
     With a prefix argument, it prompts you for which version to use.
     The intent is to make it easy to try out and compare the new
     and current parsers in your query searches.

     (This command affects standard org behaviors, such as agenda search
     and org-map-entries. The tests run with run-tag-query-tests are
     unaffected by it, *except* for the org-map-entries-1 suite which
     uses the current org-map-entries function. To see all PASS's, you
     should run the test with the new parser version installed.)

----------------
[fn:1] For example, if you move to the directory with the .el files
       in emacs, you can do
          (add-to-list 'load-path default-directory)
          (byte-compile-file "org-tag-query-parse.el")
          (byte-compile-file "tag-query-tests.el") ; optional!
          (require 'tag-query-tests)

[fn:2] Just to be clear, the commands run-tag-query-tests and
       org-use-tag-parser are convenience commands in tag-query-tests.el
       and are not part of the main code.

[-- Attachment #1.2: Type: text/html, Size: 6663 bytes --]

[-- Attachment #2: org-tag-query-parse.el --]
[-- Type: application/octet-stream, Size: 46160 bytes --]

;;; org-tag-query-parse.el -- proposed full parser for tag queries

;; Copyright (C) 2012, Christopher R. Genovese, all rights reserved.

;; Author:  Christopher Genovese <genovese@cmu.edu>
;; Version: 1.0
;;
;; Created:      Sun 29 Jul 2012 at 10:04 EDT
;; Last-Updated: Wed 15 Aug 2012 at 22:30 EDT
;; Updated By:   Christopher R. Genovese
;; Keywords: org-mode, tags, query, search
;; Package-Requires: ((org-mode 7.8))


;;; Commentary:
;;
;;  The current parser for tag query searches does not handle
;;  parenthesized expressions and thus does not allow negating complex
;;  queries. This code implements a full parser for tag queries with
;;  number of useful features (see the labeled Notes below for further
;;  comments on these features):
;; 
;;   1. Parenthesized expressions to arbitrary depth are allowed.
;;   2. A '-' can be used to negate a parenthesized term.             [Note a]
;;   3. Regex's in {} can contain braces escaped by doubling: {{ }}.  [Note b]
;;   4. Supports fast property search on HEADING and PRIORITY.        [Note c]
;;   5. Handles hyphens in property names properly.                   [Note d]
;;   6. Allows only the proper comparison operators, including ==.    [Note e]
;;   7. Allows spaces around operators and terms for readability.     [Note f]
;;   8. Parse trees use the original expression order; not a big
;;      deal, but free.
;;   9. Returned parse trees are clean, without trivial operators,
;;      and error messages during parsing are reasonably helpful.
;;   10. A few bug fixes and a cleaner `org-make-tags-matcher'.       
;;
;;  The two existing functions that are affected in the code are
;;  `org-make-tags-matcher' and `org-scan-tags'. In the new version of
;;  the former, I've unified both kinds of query parsing, leading to a
;;  shorter and cleaner function.. The new version of the latter differs
;;  in only a couple *very minor* places that capture two values that
;;  were already being computed anyway (see the diff reproduced in the
;;  comments).
;;  
;;  The main entry point is `org-make-tags-matcher', and the workhorse
;;  for the new parser is `org-tag-query-parse', with new function
;;  `org-todo-query-parse' handling the /!? todo parsing.
;;  
;;  Notes:
;;    a. There is no need to introduce a new character such as ! for
;;       negation because the semantics of the - are clear and are
;;       consistent with its use for tags. A - binds more tightly
;;       than & which in turn binds more tightly than |. A +
;;       selector can also be used for positive selection of a
;;       parenthesized term but it is equivalent to using no
;;       selector, just as for tags.
;;       
;;    b. Because \'s are so heavily used in regex's and because they
;;       have to be doubled in strings, using \'s for an additional
;;       escape layer would be messy, ambiguous, and hard to read.
;;       Only the {}'s need to be escaped and the doubling escapes
;;       {{ -> { and }} -> } are simple, readable, and fast to
;;       parse. For example: "+{abc\\{{3,7\\}}}" gives the regex
;;       "abc\\{3,7\\}". Parity makes correctness clear at a glance.
;;       
;;    c. Because headline (and priority) searches can be useful and
;;       powerful, and because the information on those fields is
;;       *already processed* in `org-scan-tags', we get those
;;       special searches *essentially for free*, requiring only two
;;       minor changes to `org-scan-tags'. See the unified diff in
;;       comments. The special PRIORITY property already exists; I
;;       added the special HEADING property for these purposes. I'm
;;       open to changing the name of course, but I do think the
;;       feature is very useful.
;; 
;;    d. I did not see it in the manual, but I think that property names
;;       with hyphens should have these \-escaped -'s in the query
;;       string, with the escaping slashes removed in the produced
;;       matcher. This is not currently done, but the new version does.
;;       See Note h for details.
;; 
;;    e. It seems desirable to support both = and == as equality operators
;;       since the latter is so common by habit. The new version allows
;;       this explicitly. The original version does as well, but the
;;       regex for the comparison operator also allows other operators
;;       <<, ><, >>, =>, and >= as well, which can produce bad matchers.
;; 
;;    f. Currently, spaces are ignored around &, |, the implicit & between
;;       terms, around the comparison operators in property searches,
;;       and around +/- selectors. Spaces are not ignored inside {}'s
;;       for a regexp match.
;;
;;  What follows is a grammar for the updated tag query dsl, which is
;;  given in an informal hybrid of BNF and regex operators. Hopefully, it's
;;  clear enough. The non-obvious terminals are ALL CAPS and are listed below.
;;  I've excluded the /!? todo query components here, mostly out of laziness,
;;  but in brief, these can end the string or any parenthesized expression.
;; 
;;  Grammar:
;;    Expression  <-  Conjunction (OR Conjunction)*
;;    Conjunction <-  Term (AND? Term)*
;;    Term        <-  SELECTOR? TAG_IDENT
;;                 |  SELECTOR? LBRACE Regex RBRACE
;;                 |  SELECTOR? PROP_IDENT CMP_OP NUMBER
;;                 |  SELECTOR? PROP_IDENT CMP_OP STRING
;;                 |  SELECTOR? PROP_IDENT CMP_OP DATE_STRING
;;                 |  SELECTOR? PROP_IDENT MATCH_OP LBRACE REGEX RBRACE
;;                 |  SELECTOR? LPAREN Expression RPAREN
;;                 
;;  Terminals (the nonobvious ones):
;;    OR = |
;;    AND = &
;;    CMP_OP = (==|=|<=|<>|>=|>|<)
;;    MATCH_OP = (==|=|<>)
;;    TAG_IDENT = [A-Za-z0-9_@#%]+         
;;    PROP_IDENT = ([A-Za-z0-9_]+(\\-)*)+  
;;    SELECTOR? = [-+]?
;;    STRING = balanced double-quoted string with escapes
;;    DATE_STRING = org style date string
;;    REGEXP = regular expression with { and } doubled to escape, {{ and }}
;;


;;; License:
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 3, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
;; Floor, Boston, MA 02110-1301, USA.
;;


;;; Code:

(require 'org)
(eval-when-compile
  (require 'cl))


;;; Utilities

(defun org-read-balanced-string (open-delim close-delim)
  "Return string delimited by OPEN-DELIM and CLOSE-DELIM with escapes.
OPEN-DELIM and CLOSE-DELIM must be *distinct* characters. Reading
begins at point in the current buffer. To include OPEN-DELIM and
CLOSE-DELIM inside the string being read, those characters must
be *doubled* and only one copy of the character is kept in the
string. The opening and closing delimiters for the read sequence
must be single copies, and an unescaped OPEN-DELIM will raise an
error."
  (when (char-equal open-delim close-delim)
    (error "Open and close delimiters must be distinct, %c" open-delim))
  (unless (char-equal (char-after) open-delim)
    (error "Missing opening %c in delimited string" open-delim))
  (forward-char 1) ; skip initial delimiter
  (let ((delim-re (format "[%c%c]" open-delim close-delim))
        (delims-unbalanced t)
        (begin (point))
        (fragments nil)
        (ch nil))
    (while (and delims-unbalanced (re-search-forward delim-re nil t))
      (setq ch (char-before))
      (cond
        ((char-equal ch open-delim)
         (setq ch (char-after))
         (if (not (and ch (char-equal ch open-delim)))
             (error "Unescaped open delimiter %c in balanced string" open-delim)
           (push (buffer-substring-no-properties begin (1- (point))) fragments)
           (setq begin (point))
           (forward-char 1)))
        ((char-equal ch close-delim)
         (setq ch (char-after))
         (if (not (and ch (char-equal ch close-delim)))
             (setq delims-unbalanced nil)
           (push (buffer-substring-no-properties begin (1- (point))) fragments)
           (setq begin (point))
           (forward-char 1)))))
    (when delims-unbalanced
      (error "Unbalanced delimiters %c%c in balanced string at char %d."
             open-delim close-delim (point)))
    (push (buffer-substring-no-properties begin (1- (point))) fragments)
    (if (null (cdr fragments))
        (car fragments)
      (apply 'concat (nreverse fragments)))))

(defun org-read-quoted-string-in-query ()
  "Read a quoted string, with escapes, starting at point.
Assume that an opening quote has already been seen. This is just
a wrapper for `read' that reports errors nicely."
  (let ((start (point)))
    (condition-case exception
        (read (current-buffer))
      (error
       (org-tquery-error
        "badly formed quoted value in property comparison" :pos start)))))

;; I'm inclined to define an error symbols here to allow finer control.
;; But error symbols don't seem to be used in the main org code, so I'll
;; forgo them here and use `error' directly.  -- CRG 31 July 2012
(defun org-tquery-error (info &rest other-args)
  "Raise a query parsing error.
INFO is an auxilliary message which is appended to the standard
message and which is treated as a format string for OTHER-ARGS.
This need/should not be capitalized. The end of OTHER-ARGS can
contain keyword-value pairs :pos <number-or-marker> and :type
<descriptive string> to control the final error message. The
former defaults to point (position in the query string) and the
latter defaults to `tag'."
  (let* ((pos (or (cadr (memq :pos other-args)) (point)))
         (qtype (or (cadr (memq :type other-args)) "tag ")))
    (error (format "Parse error in %squery at character %d, %s"
                   qtype pos (apply 'format info other-args)))))

;; This is used to define the parser symbol table at compile time.
(defmacro org-defhash-at-compile (name options &rest body) 
  "Define a hash table NAME at compile time and/or load-time.
OPTIONS is a list, possibly empty, of options to pass to
`make-hash-table'. BODY is a list of sequences (lists or
vectors), each of which contains a key value pair. The key and
the value will be evaluated, so for example, a symbol key should
be quoted."
  (declare (indent 2))
  (let* ((docstring (and (stringp (car body)) (car body)))
         (table (if docstring (cdr body) body)))
    `(eval-and-compile
       (defvar ,name (make-hash-table ,@options) ,docstring)
       ,@(mapcar (lambda (s) `(puthash ,(elt s 0) ,(elt s 1) ,name)) table))))


;;; Regex comparison functions in a form like the other comparison operators

(defun org-string-match= (string regexp)
  (string-match-p regexp string))

(defun org-string-match<> (string regexp)
  (not (string-match-p regexp string)))


;;; Parsing utility for readable matchers

(org-defhash-at-compile org-tag-query-terminals ()
  "Lexical token regexes for tag query parsing.
Hash table also contains the symbols +, * and ? that can be used
to represent repetition operators in matched expressions,
e.g., (NUMBER)+ or (SELECTOR)\?. (? must be escaped.)"
  ['TERM-BEGIN    (org-re "[-+[:alnum:]_{(]")]
  ['SELECTOR      "[-+]"]
  ['TAG-IDENT     (org-re  "[[:alnum:]_@#%:]+")]
  ['PROP-IDENT    (org-re "\\(?:[[:alnum:]_]+\\(?:\\\\-\\)*\\)+")]
  ['CMP-OP        "\\(?:==?\\|<=\\|<>\\|>=\\|<\\|>\\)"]
  ['MATCH-OP      "\\(?:==?\\|<>\\)"]
  ['CMP-RHS-BEGIN (org-re "\\(?:{\\|\\\"\\|-?[.[:digit:]]\\)")]
  ['REGEX-OPEN    "{"]
  ['GROUP-OPEN    "("]
  ['GROUP-CLOSE   ")"]
  ['OR-OP         "|"]
  ['AND-OP        "&"]
  ['DATE-STRING   "\"[[<].*?[]>]\""]
  ['INTEGER       (org-re "-?[[:digit:]]+")]
  ['NUMBER        "-?\\(?:\\.[0-9]+\\|[0-9]+\\(?:\\.[0-9]*\\)?\\)\\(?:[eE][-+]?[0-9]+\\)?"]
  ['SPACE         "[[:blank:]]"]
  ['SPACE*        "[[:blank:]]*"]
  ['TODO-MARKER   "/"]
  ['TODO-ONLY-M   "!"]
  ['TODO-KEY      "[^-+\"{}&|()]+"]
  ['*             "*"]
  ['+             "+"]
  ['\?            "?"])

(org-defhash-at-compile org-tag-query-cmp-ops (:test 'equal)
  "Maps comparison operator strings to a vector of comparison functions.
The functions are arranged in the vector for different types as follows:
         NUM   STRING       TIME       REGEX"
  ("="  [=     string=      org-time=  org-string-match=])
  ("==" [=     string=      org-time=  org-string-match=])
  ("<>" [org<> org-string<> org-time<> org-string-match<>])
  ("<"  [<     string<      org-time<  nil])
  ("<=" [<=    org-string<= org-time<= nil])
  (">=" [>=    org-string>= org-time>= nil])
  (">"  [>     org-string>  org-time>  nil]))

(eval-and-compile
  ;; I'd prefer gensyms for this, but realistically this will do.
  (defvar org-tag-query/private-opt-ch- nil
    "This variable should not be set by the user, even locally.
It should remain nil or chaos may ensue.")

  (defun org-string-as-char-p (s)
    "Is S a string of a single, possibly backslash-escaped, character?
If so, return the character this represents, otherwise nil."
    (if (stringp s)
        (let ((len (length s)))
          (or (and (= 1 len) (string-to-char s))
              (and (= 2 len) (char-equal ?\\ (string-to-char s)) (aref s 1))))
      nil))

  (defun org-tag-query-matcher<- (patterns &optional autogroup terminals next-ch)
    "Convert a list of PATTERNS to a `looking-at' query. 
AUTOGROUP, if non-nil, turns on autogrouping of singletons.
TERMINALS, if non-nil, should be a hash table for attempted
symbol lookup. See `org-match-cond' for more details on
PATTERNS's format."
    (let* ((all-strings
            (lambda (elements)
              (let ((ptr elements))
                (while (and ptr (stringp (car ptr)))
                  (setq ptr (cdr ptr)))
                (null ptr))))
           (replace-terminal
            (lambda (item)
              (cond ((not (hash-table-p terminals)) item)
                    ((symbolp item)    (gethash item terminals item))
                    (t                 item))))
           (push-all
            (lambda (src dest) (dolist (s src dest) (push s dest))))
           (alternatives
            (let (rhs acc nogroup nocapture)
              (dolist (p patterns (progn (push (nreverse rhs) acc)
                                         (nreverse acc)))
                (cond 
                 ((eq p '|)
                  (if (null rhs)
                      (org-tquery-error "misplaced alternative marker")
                    (push (nreverse rhs) acc)
                    (setq rhs nil)))
                 ((eq p :nogroup)
                  (setq nogroup t))
                 ((eq p :nocapture)
                  (setq nocapture t))
                 ((or (consp p) (vectorp p)) ; capturing/noncapturing group resp.
                  (unless nogroup ; allow nogroup/nocapture here for consistency
                    (push (if (or nocapture (vectorp p)) "\\(?:" "\\(") rhs))
                  (setq rhs (funcall push-all (mapcar replace-terminal p) rhs))
                  (unless nogroup
                    (push "\\)" rhs))
                  (setq nogroup nil nocapture nil))
                 ((and autogroup (not nogroup))
                  (push (if (or nocapture (vectorp p)) "\\(?:" "\\(") rhs)
                  (push (funcall replace-terminal p) rhs)
                  (push "\\)" rhs)
                  (setq nogroup nil nocapture nil))
                 (t
                  (push (funcall replace-terminal p) rhs)
                  (setq nogroup nil nocapture nil))))))
           (matchers
            (mapcar (lambda (pterms)
                      (let ((fst (car pterms))
                            (sch nil))
                        (cond
                         ((and (cdr pterms) (funcall all-strings pterms))
                          `(looking-at ,(apply 'concat pterms)))
                         ((cdr pterms)
                          `(looking-at (concat ,@pterms)))
                         ((and next-ch (setq sch (org-string-as-char-p fst)))
                          `(and ,next-ch
                                (char-equal ,next-ch ,sch)
                                (setq org-tag-query/private-opt-ch- ,sch)))
                         (t
                          `(looking-at ,fst)))))
                    alternatives)))
      (if (cdr matchers)
          `(or ,@matchers)
        `,(car matchers)))))

(defmacro org-match-cond (options &rest clauses)
  "Like `cond', but allows special forms in the clauses that lookahead in,
extract from, and move in the current buffer. The special forms
are described below. OPTIONS, if non-nil, is either a symbol,
SYMBOL-TABLE, bound to a hash table for symbol lookup, or a list
of the form (SYMBOL-TABLE NEXT-CHAR-SYM &rest BINDINGS). If NEXT-CHAR-SYM
is not nil, it should be a symbol that will be bound to the next character
and used to optimize the matching of especially simple patterns, as described
below. BINDINGS are standard let bindings which will visible in the
CLAUSES. CLAUSES are structured like the clauses in `cond'.

   Lookahead:
     (<-  PATTERN... [| PATTERN...]*)  -- symbol lookup in SYMBOL-HASH
     (<<- PATTERN... [| PATTERN...]*)  -- symbol lookup + singleton autogrouping
     (<<= PATTERN... [| PATTERN...]*)  -- no symbol lookup or autogrouping

     Each pattern in the list is either a string, a symbol, a
     list of strings and symbols -- representing capturing
     groups, or a vector of strings and symbols -- representing
     non-capturing groups. The |'s separate alternatives that are
     tested lazily (a la `or'); the eventual strings computed for
     the patterns in each alternative are concatenated together
     to form a regular expression which is tested with
     `looking-at'. When symbol lookup is in effect (<- and <<-
     forms), symbols in a pattern are first looked up in
     SYMBOL-TABLE if it exists, and replaced with the
     corresponding value if present. If all the patterns's in an
     alternative resolve to strings at compile time, the regular
     expression is computed at compile time and all the forms
     reduce to a single call to `looking-at'. Otherwise, the
     regular expression is computed at runtime.

     In the special case where there are no alternatives, the
     pattern is a string representing a single character at
     compile time (one character or a backslash-escaped
     character), and NEXT-CHAR-SYM is a non-nil symbol, the cond
     clause is optimized to do a character comparison rather than
     a `looking-at'. Specifically, NEXT-CHAR-SYM is bound to the
     character at point before any tests and used via
     `char-equal' for this optimized match. Movement and string
     forms with group 0, i.e., (@ end 0), ($ 0), ($$ 0), see
     below, still work as expected in this case. To suppress the
     character optimization when NEXT-CHAR-SYM is non-nil, for
     instance to match a regular expression `.', it is sufficient
     to include an empty string in the pattern list or to put the
     term in a non-capturing group..

     In the <<- form, each singleton pattern (strings or symbols)
     is automatically put in a capturing group, unless preceded by
     :nogroup (inhibiting group) or :nocapture (inhibiting capture).

   Movement:
     (@ FROM GROUP [OFFSET]) 
        Moves point to a position relative to a match GROUP,
        which should be a non-negative integer. This has no
        effect if the group did not match, except an (@ end 0)
        always moves to the end of what matched even if the
        clause was optimized into a character match. FROM can be
        either the symbol `end' or `begin', which matches the end
        or beginning of the group, or a function which is called
        with group as an argument. Optional OFFSET, if non-nil,
        is added to the specified position.

   String Extraction:
     ($ GROUP)   The matched string for group GROUP, or nil.
                 A ($ 0) always works, even with character optimization.
"
  (declare (indent 1))
  (let* ((opt-listp (consp options))
         (sym-table (if opt-listp (car options)      options))
         (next-char (if opt-listp (cadr options)     nil))
         (next-sym  (if next-char `',next-char nil))
         (bindings  (if opt-listp (nthcdr 2 options) nil)))
   `(macrolet ((<- (&rest patterns)     ; lookup
                   `,(org-tag-query-matcher<- patterns nil ,sym-table ,next-sym))
               (<<- (&rest patterns)    ; lookup + autogrouping
                    `,(org-tag-query-matcher<- patterns t ,sym-table ,next-sym))
               (<<= (&rest patterns)    ; no lookup or autogrouping
                    `,(org-tag-query-matcher<- patterns nil nil ,next-sym))
               (@ (from group &optional offset) ; move point relative to group
                  ;; Handling the character-match optimization requires
                  ;; checking if a character match was made so an (@ end 0)
                  ;; moves forward instead of referring to the match
                  ;; data. The idea here is to only check that case when
                  ;; the optimization was requested in the first place
                  ;; and then to do as much work as possible at compile
                  ;; time. Admittedly, this part has gotten a bit crazy,
                  ;; but it does produce good code. -- CRG 02 Aug 2012
                  ,(if (not next-char)
                       `(let ((ipos
                               (case from
                                 (end `(or (match-end ,group) (point)))
                                 (begin `(or (match-beginning ,group) (point)))
                                 (t `(,from ,group)))))
                          `(goto-char ,(if offset `(+ ,ipos ,offset) ipos)))
                     `(let ((ipos (case from
                                    (end
                                     `(if org-tag-query/private-opt-ch-
                                          ,(cond
                                            ((and (integerp group) (zerop group))
                                             '(min (1+ (point)) (point-max)))
                                            ((integerp group)
                                             '(point))
                                            (t
                                             `(min (+ (point)
                                                      (if (zerop ,group) 1 0))
                                                   (point-max))))
                                        (or (match-end ,group) (point))))
                                    (begin
                                     `(or (and
                                           (not org-tag-query/private-opt-ch-)
                                           (match-beginning ,group))
                                          (point)))
                                    (t `(,from ,group)))))
                        `(goto-char ,(if offset `(+ ,ipos ,offset) ipos)))))
               ($ (group)          ; string or nil if no match for group
                  ,(if (not next-char)
                       ``(match-string ,group)
                     ``(if org-tag-query/private-opt-ch-
                          ,(if (integerp group) ;; w/literal group, just do it
                               (if (zerop group) ;;  likely the common case
                                   '(string org-tag-query/private-opt-ch-) nil)
                             `(if (zerop ,group)
                                  (string org-tag-query/private-opt-ch-) nil))
                        (match-string ,group)))))
      (let (,@bindings
            ,@(if next-char (list `(,next-char (char-after))) nil)
            ,@(if next-char (list '(org-tag-query/private-opt-ch- nil)) nil))
        (cond
         ,@clauses)))))


;;; The tag query parser itself

(defun org-tag-query-parse (todo-only)
  ;; Works in current buffer with string to be parsed starting at point.
  (let ((parse-stack nil)
        (paren-count 0)
        neg-select got-select
        todo-bang todo-match)
    (labels
        ((emit (&rest items)
               (dolist (item items) (push item parse-stack)))
         (no-term-p ()
                    (let ((top (car parse-stack)))
                      (and (symbolp (car parse-stack)) (not (eq top t)))))
         (negate-if (negate item)
                    (if negate `(not ,item) item))
         (thread (&rest iterations)
                 (dolist (_ iterations)
                   (let (entries new-entry type)
                     (while (or (eq t (car parse-stack))
                                (not (symbolp (car parse-stack))))
                       (setq entries (cons (pop parse-stack) entries)))
                     (unless (and entries parse-stack)
                       (org-tquery-error "empty subexpression"))
                     (case (setq type (pop parse-stack))
                       ((and or)
                        (setq new-entry 
                              (if (cdr entries)
                                  (cons type entries)
                                (car entries))))
                       (not
                        (assert (null (cdr entries)) nil "not is unary")
                        (let ((arg (car entries)))
                          (setq new-entry
                                (if (and (consp arg) (eq (car arg) 'not))
                                    (cadr arg)
                                  `(not ,arg)))))
                       (identity
                        (assert (null (cdr entries)) nil "() is one expression")
                        (setq new-entry (car entries)))
                       (t                  ; this really shouldn't happen
                        (org-tquery-error "invalid symbol %s on stack." type)))
                     (emit new-entry))))
         (tag-check (id &optional negate)
                    (let ((check `(member ,id tags-list)))
                      (if negate `(not ,check) check)))
         (prop-check (prop &optional numericp)
                     (cond
                      ((string-equal prop "LEVEL")
                       'level)
                      ((member prop '("TODO" "HEADING" "PRIORITY"))
                       `(or ,(intern (downcase prop)) ""))
                      ((string-equal prop "CATEGORY")
                       '(or (get-text-property (point) 'org-category) ""))
                       (numericp
                        `(string-to-number
                          (or (org-cached-entry-get nil ,prop) "")))
                       (t
                        `(or (org-cached-entry-get nil ,prop) "")))))
      ;; Seed outermost expression in parse tree
      (emit 'or 'and)
      (skip-chars-forward (org-re "[:blank:]"))

      (while (not (eobp))
        ;; Process a term
        ;;   Look for the selector char first
        (org-match-cond org-tag-query-terminals
          ((<- (SELECTOR) SPACE*)
           (@ end 0)
           (setq got-select t
                 neg-select (char-equal (string-to-char ($ 1)) ?-)))
          (t
           (setq got-select nil
                 neg-select nil)))
        ;;   Now look for the rest of the term
        (org-match-cond (org-tag-query-terminals char-at-point)
         ((<- (PROP-IDENT) SPACE* (CMP-OP) SPACE* (CMP-RHS-BEGIN))
          (@ begin 3)
          (let* ((prop (save-match-data
                         (replace-regexp-in-string
                          "\\\\-" "-" ($ 1) t t)))
                 (cmp  ($ 2))
                 (indx (case (char-after)
                         (?\{ 3)
                         (?\" (org-match-cond org-tag-query-terminals
                                ((<- DATE-STRING) 2)
                                (t 1)))
                         (t 0)))
                 (op-f (aref (gethash cmp org-tag-query-cmp-ops) indx))
                 (rhs
                  (case indx
                    (0 (org-match-cond org-tag-query-terminals
                         ((<- NUMBER) (@ end 0) (string-to-number ($ 0)))
                         (t (org-tquery-error
                             "invalid number on rhs of property comparison"))))
                    (1 (org-read-quoted-string-in-query))
                    (2 (org-matcher-time (org-read-quoted-string-in-query)))
                    (3 (org-read-balanced-string ?\{ ?\}))))
                 (form (list op-f (prop-check prop (zerop indx)) rhs)))
            (unless op-f
              (org-tquery-error "invalid operator for property regexp match"))
            (emit (negate-if neg-select form))))
         ((<- TAG-IDENT)
          (@ end 0)
          (emit (tag-check ($ 0) neg-select)))
         ((<- REGEX-OPEN)
          (let ((regex (org-read-balanced-string ?\{ ?\})))
            (emit (negate-if neg-select `(org-match-any-p ,regex tags-list)))))
         ((<- GROUP-OPEN)
          (@ end 0)
          (emit (if neg-select 'not 'identity) 'or 'and)
          (incf paren-count))
         (got-select
          (org-tquery-error "trailing selector with no term"))
         ((<- TODO-MARKER (TODO-ONLY-M)\? SPACE*)
          (@ end 0)
          (setq todo-bang  (and ($ 1) t))
          (when (no-term-p) ; no tag query terms before this
            (emit t))
          (unless (eobp)
            (setq todo-match (org-todo-query-parse))))
         ((no-term-p)
          (org-tquery-error "missing the expected term"))
         ((<- GROUP-CLOSE)    ; end of subexpression, clean up
          (@ end 0)
          (decf paren-count)
          (when (< paren-count 0) (org-tquery-error "mismatched )'s"))
          (thread 'conjunction 'disjunction)
          ;; combine current tag expression and todo matcher, if any
          (when (or todo-bang todo-match)  
            (emit `(and ,@(and todo-bang '((member todo org-not-done-keywords)))
                        ,(pop parse-stack) ; <- tag expr for this () group
                        ,@todo-match))
            (setq todo-bang nil todo-match nil))
          (thread 'selector))
         ((<- AND-OP)         ; continue conjunction, expect a term
          (@ end 0))                   
         ((<- OR-OP)          ; start or continue a disjunction
          (@ end 0)
          (thread 'conjunction)
          (emit 'and))
         (t
          (org-tquery-error "invalid token %c during query parse"
                            (char-after))))
        ;; Allow spaces around terms, operators, and parens
        (skip-chars-forward (org-re "[:blank:]")))

      (unless (zerop paren-count)
        (org-tquery-error "missing )s in query string"))

      ;; Build the final parse tree by threading the stack
      (while (cdr parse-stack)
        (thread 'any))

      ;; Put the pieces together (todo-match is wrapped in a list)
      (let ((tag-matcher
             (if (eq (car parse-stack) t)
                 t
               `(progn
                  (setq org-cached-props nil)
                  ,(car parse-stack))))
            (todo-restrict
             (if (or todo-bang todo-only)
                 '((member todo org-not-done-keywords))
               nil)))
        (if (or todo-restrict todo-match)
            `(and ,@todo-restrict ,tag-matcher ,@todo-match)
          tag-matcher)))))

(defun org-todo-query-parse ()
  ;; Todo terms match TERM (AND-OP? TERM)* between OR-OP's,
  ;; where TERM = "\\([-+:]\\)?\\({[^}]*}\\|[^-+\"{}&|]+\\)"
  (let (orlist andlist neg-select got-select done)
    (while (not (or done (eobp)))
      (org-match-cond org-tag-query-terminals
        ((<- (SELECTOR) SPACE*)
         (@ end 0)
         (setq got-select t
               neg-select (char-equal (string-to-char ($ 1)) ?-)))
        (t
         (setq got-select nil
               neg-select nil)))
      (org-match-cond (org-tag-query-terminals char-at-point)
        ((<- REGEX-OPEN)
         (let* ((regex (org-read-balanced-string ?\{ ?\})))
            (push (if neg-select
                      `(org-string-match<> (or todo "") ,regex)
                    `(org-string-match= (or todo "") ,regex))
                  andlist)))
        ((<- TODO-KEY)
         (@ end 0)
         (let ((match `(equal todo ,($ 0))))
           (push (if neg-select `(not ,match) match) andlist)))
        ((<- AND-OP)
         (@ end 0)
         (cond
          (got-select
           (org-tquery-error "trailing selector with no todo term"))
          ((null andlist)
           (org-tquery-error "missing todo term before &"))))
        (got-select
         (org-tquery-error "trailing selector with no todo term"))
        ((<- OR-OP)
         (@ end 0)
         (when (null andlist)
           (org-tquery-error "missing todo term before |"))
         (push (if (cdr andlist)
                   (cons 'and (nreverse andlist))
                 (car andlist))
               orlist)
         (setq andlist nil))
        ((<- GROUP-CLOSE) ; end todo parse and return to main parser
         (setq done t))
        (t
         (org-tquery-error "invalid token %c in todo expression"
                           (char-after))))
      (skip-chars-forward (org-re "[:blank:]")))
    (when andlist
      (push (if (cdr andlist) (cons 'and (nreverse andlist)) (car andlist))
            orlist))
    (cond               ; result will be spliced into an and
     ((cdr orlist)        ; wrap in a list for later splicing
      (list (cons 'or (nreverse orlist))))
     ((and (consp (car orlist)) (eq 'and (car (car orlist))))
      (cdr (car orlist))) ; splice (and ...) as (...) directly
     (t                   ; wrap in a list for later splicing
      (list (car orlist))))))


;;; Modified `org-make-tags-matcher' and `org-scan-tags' that use the new parser

;;; The main change to `org-make-tags-matcher' is to insert the new tag
;;; parser, but this allowed me to shorten and clean up the code, fix
;;; one very minor bug (see NOTE below), and update the docstring.
;;; I've also separated out the todo parsing into a separate function
;;; for clarity and symmetry, though I've left the method as is.
;;; 
;;; The changes to `org-scan-tags' are minor and essentially free, and 
;;; I include the context diff in comments below.
;;;
;;; These both are drawn from the 7.8.11 code. To facilitate testing,
;;; I've added an -NEW to the names of these functions for the moment,
;;; but that should be changed if they are used. The temporary function
;;; `org-tmp-use-tag-parser' allows switching between old and new for
;;; testing. See also the file `tag-query-tests.el' that runs some basic
;;; tests.

;; Note: Successive matches (\G-style) in a fixed string are not possible
;; in emacs (without making repeated copies of substrings) because there
;; is no way to anchor a string-match at the start position argument.
;; (I have suggested using the zero-length assertion \= in a string to
;; anchor at that position, analogous to its use in buffer searches. If
;; you're with me, spread the word.)
;;
;; So instead of marching through the string copying substrings, we
;; process the query string in a temporary buffer. This is more
;; idiomatic elisp in any case, and is quite fast and convenient it
;; turns out. Doing it the other way is possible as well, by making
;; changes in a few places, particularly the org-match-cond macro and
;; org-tag-query-parse in a few places. But so far I like this approach.

(defun org-make-tags-matcher (match)
  "Create the TAGS/TODO matcher form for the selection string MATCH.

The variable `todo-only' is scoped dynamically into this
function; it will be set to t if the matcher restricts matching
to TODO entries, otherwise will not be touched.

Returns a cons of the selection string MATCH and the constructed
lisp form implementing the matcher. The matcher is to be
evaluated at an Org entry, with point on the headline, and
returns t if the entry matches the selection string MATCH. The
returned lisp form may reference four variables with information
about the entry, which must be bound around the form's
evaluation: todo, the TODO keyword at the entry (or nil of none);
heading, the text of the heading for the entry; priority, the
priority cookie for the entry or nil; and tags-list, the list of
all tags at the entry including inherited ones. Additionally, the
category of the entry (if any) must be specified as the text
property 'org-category on the headline.

See also `org-scan-tags'.
"
  (declare (special todo-only))
  (unless (boundp 'todo-only)
    (error "org-make-tags-matcher expects todo-only to be scoped in"))
  (unless match
    ;; Get a new match request, with completion
    (let ((org-last-tags-completion-table
	   (org-global-tags-completion-table)))
      (setq match (org-completing-read-no-i
		   "Match: " 'org-tags-completion-function nil nil nil
		   'org-tags-history))))

  ;; Parse the string into a matcher lisp form
  (cond
   ((or (not match) (not (string-match-p "\\S-" match)))
    (cons match t))
   ((string-match "^\\s-*\\([^-+A-Za-z0-9_@%#:{(/ \t]\\)" match)
    (org-tquery-error "invalid characters in query string"
                      :pos (match-beginning 1)))
   (t
    (with-temp-buffer
      (insert match)
      (goto-char (point-min))
      (cons match (org-tag-query-parse todo-only))))))

;; The changes to org-scan-tags are minor and essentially free.
;; A diff -U 2 against org.el from 7.8.11 with only this function
;; changed follows.
;;
;; --- org.el      2012-07-31 15:32:17.000000000 -0400
;; +++ modified-org.el     2012-07-31 15:20:56.000000000 -0400
;; @@ -12830,5 +12830,5 @@
;;                      " *\\(\\<\\("
;;                      (mapconcat 'regexp-quote org-todo-keywords-1 "\\|")
;; -                    (org-re "\\)\\>\\)? *\\(.*?\\)\\(:[[:alnum:]_@#%:]+:\\)?[ \t]*$")))
;; +                    (org-re "\\)\\>\\)?[ \t]*\\(?:\\[#\\(.\\)\\]\\)?[ \t]*\\(.*?\\)\\(:[[:alnum:]_@#%:]+:\\)?[ \t]*$")))
;;          (props (list 'face 'default
;;                       'done-face 'org-agenda-done
;; @@ -12848,5 +12848,5 @@
;;          (tags-alist (list (cons 0 org-file-tags)))
;;          (llast 0) rtn rtn1 level category i txt
;; -        todo marker entry priority)
;; +        todo marker entry heading priority priority-num)
;;      (when (not (or (member action '(agenda sparse-tree)) (functionp action)))
;;        (setq action (list 'lambda nil action)))
;; @@ -12860,5 +12860,7 @@
;;         (catch :skip
;;           (setq todo (if (match-end 1) (org-match-string-no-properties 2))
;; -               tags (if (match-end 4) (org-match-string-no-properties 4)))
;; +                priority (if (match-end 3) (org-match-string-no-properties 3))
;; +                heading (org-match-string-no-properties 4)
;; +               tags (if (match-end 5) (org-match-string-no-properties 5)))
;;           (goto-char (setq lspos (match-beginning 0)))
;;           (setq level (org-reduced-level (funcall outline-level))
;; @@ -12938,5 +12940,5 @@
;;                          tags-list
;;                          )
;; -                   priority (org-get-priority txt))
;; +                   priority-num (org-get-priority txt))
;;               (goto-char lspos)
;;               (setq marker (org-agenda-new-marker))
;; @@ -12944,5 +12946,5 @@
;;                 'org-marker marker 'org-hd-marker marker 'org-category category
;;                 'todo-state todo
;; -               'priority priority 'type "tagsmatch")
;; +               'priority priority-num 'type "tagsmatch")
;;               (push txt rtn))
;;              ((functionp action)
;; 

(defun org-scan-tags (action matcher todo-only &optional start-level)
  "Scan headline tags with inheritance and produce output ACTION.

ACTION can be `sparse-tree' to produce a sparse tree in the current buffer,
or `agenda' to produce an entry list for an agenda view.  It can also be
a Lisp form or a function that should be called at each matched headline, in
this case the return value is a list of all return values from these calls.

MATCHER is a Lisp form to be evaluated, testing if a given set of tags
qualifies a headline for inclusion.  When TODO-ONLY is non-nil,
only lines with a not-done TODO keyword are included in the output.
This should be the same variable that was scoped into
and set by `org-make-tags-matcher' when it constructed MATCHER.

START-LEVEL can be a string with asterisks, reducing the scope to
headlines matching this string."
  (require 'org-agenda)
  (let* ((re (concat "^"
		     (if start-level
			 ;; Get the correct level to match
			 (concat "\\*\\{" (number-to-string start-level) "\\} ")
		       org-outline-regexp)
		     " *\\(\\<\\("
		     (mapconcat 'regexp-quote org-todo-keywords-1 "\\|")
		     (org-re "\\)\\>\\)?[ \t]*\\(?:\\[#\\(.\\)\\]\\)?[ \t]*\\(.*?\\)\\(:[[:alnum:]_@#%:]+:\\)?[ \t]*$")))
	 (props (list 'face 'default
		      'done-face 'org-agenda-done
		      'undone-face 'default
		      'mouse-face 'highlight
		      'org-not-done-regexp org-not-done-regexp
		      'org-todo-regexp org-todo-regexp
		      'org-complex-heading-regexp org-complex-heading-regexp
		      'help-echo
		      (format "mouse-2 or RET jump to org file %s"
			      (abbreviate-file-name
			       (or (buffer-file-name (buffer-base-buffer))
				   (buffer-name (buffer-base-buffer)))))))
	 (case-fold-search nil)
	 (org-map-continue-from nil)
         lspos tags tags-list
	 (tags-alist (list (cons 0 org-file-tags)))
	 (llast 0) rtn rtn1 level category i txt
	 todo marker entry heading priority priority-num)
    (when (not (or (member action '(agenda sparse-tree)) (functionp action)))
      (setq action (list 'lambda nil action)))
    (save-excursion
      (goto-char (point-min))
      (when (eq action 'sparse-tree)
	(org-overview)
	(org-remove-occur-highlights))
      (while (re-search-forward re nil t)
	(setq org-map-continue-from nil)
	(catch :skip
	  (setq todo (if (match-end 1) (org-match-string-no-properties 2))
                priority (if (match-end 3) (org-match-string-no-properties 3))
                heading (org-match-string-no-properties 4)
		tags (if (match-end 5) (org-match-string-no-properties 5)))
	  (goto-char (setq lspos (match-beginning 0)))
	  (setq level (org-reduced-level (funcall outline-level))
		category (org-get-category))
	  (setq i llast llast level)
	  ;; remove tag lists from same and sublevels
	  (while (>= i level)
	    (when (setq entry (assoc i tags-alist))
	      (setq tags-alist (delete entry tags-alist)))
	    (setq i (1- i)))
	  ;; add the next tags
	  (when tags
	    (setq tags (org-split-string tags ":")
		  tags-alist
		  (cons (cons level tags) tags-alist)))
	  ;; compile tags for current headline
	  (setq tags-list
		(if org-use-tag-inheritance
		    (apply 'append (mapcar 'cdr (reverse tags-alist)))
		  tags)
		org-scanner-tags tags-list)
	  (when org-use-tag-inheritance
	    (setcdr (car tags-alist)
		    (mapcar (lambda (x)
			      (setq x (copy-sequence x))
			      (org-add-prop-inherited x))
			    (cdar tags-alist))))
	  (when (and tags org-use-tag-inheritance
		     (or (not (eq t org-use-tag-inheritance))
			 org-tags-exclude-from-inheritance))
	    ;; selective inheritance, remove uninherited ones
	    (setcdr (car tags-alist)
		    (org-remove-uninherited-tags (cdar tags-alist))))
	  (when (and

		 ;; eval matcher only when the todo condition is OK
		 (and (or (not todo-only) (member todo org-not-done-keywords))
		      (let ((case-fold-search t)) (eval matcher)))

		 ;; Call the skipper, but return t if it does not skip,
		 ;; so that the `and' form continues evaluating
		 (progn
		   (unless (eq action 'sparse-tree) (org-agenda-skip))
		   t)

		 ;; Check if timestamps are deselecting this entry
		 (or (not todo-only)
		     (and (member todo org-not-done-keywords)
			  (or (not org-agenda-tags-todo-honor-ignore-options)
			      (not (org-agenda-check-for-timestamp-as-reason-to-ignore-todo-item)))))

		 ;; Extra check for the archive tag
		 ;; FIXME: Does the skipper already do this????
		 (or
		  (not (member org-archive-tag tags-list))
		  ;; we have an archive tag, should we use this anyway?
		  (or (not org-agenda-skip-archived-trees)
		      (and (eq action 'agenda) org-agenda-archives-mode))))

	    ;; select this headline

	    (cond
	     ((eq action 'sparse-tree)
	      (and org-highlight-sparse-tree-matches
		   (org-get-heading) (match-end 0)
		   (org-highlight-new-match
		    (match-beginning 1) (match-end 1)))
	      (org-show-context 'tags-tree))
	     ((eq action 'agenda)
	      (setq txt (org-agenda-format-item
			 ""
			 (concat
			  (if (eq org-tags-match-list-sublevels 'indented)
			      (make-string (1- level) ?.) "")
			  (org-get-heading))
			 category
			 tags-list
			 )
		    priority-num (org-get-priority txt))
	      (goto-char lspos)
	      (setq marker (org-agenda-new-marker))
	      (org-add-props txt props
		'org-marker marker 'org-hd-marker marker 'org-category category
		'todo-state todo
		'priority priority-num 'type "tagsmatch")
	      (push txt rtn))
	     ((functionp action)
	      (setq org-map-continue-from nil)
	      (save-excursion
		(setq rtn1 (funcall action))
		(push rtn1 rtn)))
	     (t (error "Invalid action")))

	    ;; if we are to skip sublevels, jump to end of subtree
	    (unless org-tags-match-list-sublevels
	      (org-end-of-subtree t)
	      (backward-char 1))))
	;; Get the correct position from where to continue
	(if org-map-continue-from
	    (goto-char org-map-continue-from)
	  (and (= (point) lspos) (end-of-line 1)))))
    (when (and (eq action 'sparse-tree)
	       (not org-sparse-tree-open-archived-trees))
      (org-hide-archived-subtrees (point-min) (point-max)))
    (nreverse rtn)))


(provide 'org-tag-query-parse)

;;; org-tag-query-parse.el ends here

[-- Attachment #3: tag-query-tests.el --]
[-- Type: application/octet-stream, Size: 42589 bytes --]

;;; tag-query-tests.el -- test suites for new org tag query parser

;; Copyright (C) 2012, Christopher R. Genovese, all rights reserved.

;; Author:  Christopher Genovese <genovese@cmu.edu>
;; Version: 1.0
;;
;; Created:      Wed 01 Aug 2012 at 20:43 EDT
;; Last-Updated: Wed 15 Aug 2012 at 21:22 EDT
;; Updated By:   Christopher R. Genovese
;; Keywords: org-mode, tags, query, search
;; Package-Requires: ((org-mode 7.8))


;;; Commentary:
;;
;;  Provides a simple interface for trying the new parser implemented in
;;  the file `org-tag-query-parse.el'. But load this file FIRST!
;;
;;  The two main commands are `org-use-tag-parser' and `run-tag-query-tests':
;;
;;   1. The command `org-use-tag-parser' let's you choose (or toggle) between
;;      the new and original parsers; with a prefix argument, it will prompt
;;      you for the choice.
;;
;;   2. The command `run-tag-query-tests' runs all the test suites and lists
;;      the results in a separate buffer. Use a prefix argument to get a more
;;      detailed listing of results. The variable `org-which-tag-parser'
;;      tells you which version is current.
;;  
;;  Note: This should be loaded *before* `org-tag-query-parse.el', which
;;  should be visible on the load path. It is also recommended that you
;;  byte compile `org-tag-query-parse.el' first. You can compile this
;;  file as well, if you like.
;;
;;  The remainder of the file defines the tests and test framework.
;;
;;  A few details (if you care)
;;  ---------------------------
;;  The existing functions from org that are modified by
;;  `org-tag-query-parse.el' are `org-make-tags-matcher' and
;;  `org-scan-tags'. After loading *this* package, three versions of each
;;  these functions will be available:
;;
;;     org-make-tags-matcher-ORIGINAL     -- the original org  version
;;     org-scan-tags-ORIGINAL
;;     
;;     org-make-tags-matcher-NEW          -- the new org-tag-query-parse version
;;     org-scan-tags-NEW
;;
;;     org-make-tags-matcher              -- the current version, initially -NEW
;;     org-scan-tags
;;
;;  The function `org-use-tag-parser' switches the current version of these
;;  functions to either the -NEW or -ORIGINAL versions. This allows you to
;;  try out and compare the two parsers. 
;;
;;  You can run the tests by using the command `run-tag-query-tests' which summarizes
;;  the results in a new buffer. The function `tag-test-run' below allows finer
;;  control over which tests are run. The forms `tag-test-suite' define the
;;  test suites as documented below.

(require 'org)
(eval-when-compile
  (require 'cl))

;;; Save the ORIGINAL and NEW versions
;;;   This is why this file needs to be loaded *before* org-tag-query-parse.el.

(unless (featurep 'org-tag-query-parse)
  (fset 'org-scan-tags-ORIGINAL (symbol-function 'org-scan-tags))
  (fset 'org-make-tags-matcher-ORIGINAL (symbol-function 'org-make-tags-matcher))

  (require 'org-tag-query-parse)

  (fset 'org-scan-tags-NEW (symbol-function 'org-scan-tags))
  (fset 'org-make-tags-matcher-NEW (symbol-function 'org-make-tags-matcher)))


;;; org-use-tag-parser -- switches between new and original version

(defvar org-which-tag-parser 'new
  "Version of the tag query parser that is current, new or original.")

(defun org-use-tag-parser (&optional which)
  "Switch between tag query parsers. 
If nil or 'toggle, it toggles between new and original.
Otherwise, WHICH must be either 'new or 'original."
  (interactive
   (list
    (if (not current-prefix-arg)
        'toggle
      (let ((mesg "Which parser [t]oggle, [n]ew, or [o]riginal? ")
            (mesg2 "Please choose one of [t]oggle, [n]ew, or [o]riginal! ")
            (choice nil))
        (while (not choice)
          (setq choice
                (case (read-char mesg)
                  (?t 'toggle)
                  (?n 'new)
                  (?o 'original)
                  (t
                   (setq mesg mesg2)
                   nil))))
        choice))))
  (ecase (or which 'toggle) 
    (toggle
     (org-use-tag-parser (if (eq org-which-tag-parser 'original) 'new 'original)))
    (new
     (fset 'org-scan-tags (symbol-function 'org-scan-tags-NEW))
     (fset 'org-make-tags-matcher (symbol-function 'org-make-tags-matcher-NEW))
     (message "Installing new tag/todo-query parser")
     (setq org-which-tag-parser 'new))
    (original
     (fset 'org-scan-tags (symbol-function 'org-scan-tags-ORIGINAL))
     (fset 'org-make-tags-matcher (symbol-function 'org-make-tags-matcher-ORIGINAL))
     (message "Installing original tag/todo-query parser")
     (setq org-which-tag-parser 'original))))


;;; run-tag-query-tests -- runs test and nicely displayes results

(defmacro tag-query-test-pstring (string &rest face-props)
  "STRING with its face properties set to FACE-PROPS.
If FACE-PROPS is empty, return the unpropertized string."
  (declare (indent 1))
  (if (null face-props)
      `,string
  `(propertize ,string 'face '(,@face-props))))

(defun run-tag-query-tests (&optional give-details)
  "Run all test suites for the new tag query parser and display
in a temporary buffer *TagQueryTests*. With a prefix arg,
give detailed results of each test; otherwise, give a summary
for each suite."
  (interactive "P")
  (let* ((detail (if give-details :results :summarize))
	 (buffer (get-buffer-create "*TagQueryTests*"))
	 (display (lambda (results)
		    ;; This is a bit of a mess, but oh well.
		    (dolist (result results)
		      (if (and (consp result) (consp (cdr result)))
			  (dolist (ind-res result)
			    (cond
			     ((consp ind-res)
			      (insert "    ")
			      (cond
			       ((null (car ind-res))
				(insert (tag-query-test-pstring "Fail" :foreground "red") "  ")
				(prin1 (cdr ind-res) buffer))
			       ((eq (car ind-res) t)
				(insert (tag-query-test-pstring "Pass" :foreground "green") "  ")
				(prin1 (cdr ind-res) buffer))
			       (t
				(insert (tag-query-test-pstring "Pass" :foreground "green") "  ")
				(prin1 (cdr ind-res) buffer)
				(insert (tag-query-test-pstring "  =>  " :foreground "green"))
				(princ (car ind-res) buffer)))
			      (insert "\n"))
			     ((symbolp ind-res)
			      (insert (tag-query-test-pstring (symbol-name ind-res)
							      :foreground "blue") "\n"))))
			(if (atom result)
			    (princ result buffer)
			  (insert
			   (if (cdr result)
			       (tag-query-test-pstring "All Passed" :foreground "green")
			     (tag-query-test-pstring   "Failures  " :foreground "red"))
			   "  "
			   (tag-query-test-pstring (symbol-name (car result))
						   :foreground "blue")
			   "\n")))))))
    (with-current-buffer buffer
      (setq buffer-read-only nil)
      (erase-buffer)
      (goto-char (point-min))
      (insert
       (tag-query-test-pstring
        "Tag Query Parser Test Results"
        :foreground "midnight blue" :weight bold :height 1.44)
       "\n")
      (if give-details
          (insert "\n")
        (insert (tag-query-test-pstring
                    "Give prefix argument to M-x run-tag-query-tests for detailed results."
                  :foreground "midnight blue")
                "\n\n"))
      (insert
       (tag-query-test-pstring
        "Test results by suite" :underline "midnight blue" :weight bold)
       "\n")
      (funcall display (tag-test-run detail))
      (insert
       "\n"
       (tag-query-test-pstring
           "Mapping Tests on an Org File" :underline "midnight blue" :weight bold) ; currently only one suite
       "\n")
      (funcall display (tag-test-other-tests detail))
      (goto-char (point-min))
      (view-mode 1))
    (pop-to-buffer buffer)))


;;; A somewhat messy test framework

;; Comparing org-tag-query-parser and org-make-tag-matcher is
;; complicated by the different ordering of leaves in the trees.
;; Specifically, the former puts the terms in the given order,
;; but the latter (the existing org code) reverses the terms.
;; Parsing the string to reverse would require testing the secondary
;; parser and turtles all the way down.
;;
;; Two approaches then: specify the strings manually in pairs, or
;; define transform that accounts for the differences. Here
;; `tag-test-suite' mostly takes the former approach, unless only one
;; string is given in which case it uses `tag-test-transform' to remap
;; the original forms. The function `tag-test-transform' tansforms the
;; existing forms into new forms except it ignores PRIORITY and HEADING
;; queries which are treated differently in the new code.

(eval-when-compile
  (defun tag-test-read-balanced-string (open-delim close-delim)
    "Return string delimited by OPEN-DELIM and CLOSE-DELIM with escapes.
OPEN-DELIM and CLOSE-DELIM must be *distinct* characters. Reading
begins at point in the current buffer. To include OPEN-DELIM and
CLOSE-DELIM inside the string being read, those characters must
be *doubled* and only one copy of the character is kept in the
string. The opening and closing delimiters for the read sequence
must be single copies, and an unescaped OPEN-DELIM will raise an
error."
    (when (char-equal open-delim close-delim)
      (error "Open and close delimiters must be distinct, %c" open-delim))
    (unless (char-equal (char-after) open-delim)
      (error "Missing opening %c in delimited string" open-delim))
    (forward-char 1)                    ; skip initial delimiter
    (let ((delim-re (format "[%c%c]" open-delim close-delim))
          (delims-unbalanced t)
          (begin (point))
          (fragments nil)
          (ch nil))
      (while (and delims-unbalanced (re-search-forward delim-re nil t))
        (setq ch (char-before))
        (cond
         ((char-equal ch open-delim)
          (setq ch (char-after))
          (if (not (and ch (char-equal ch open-delim)))
              (error "Unescaped open delimiter %c in balanced string" open-delim)
            (push (buffer-substring-no-properties begin (1- (point))) fragments)
            (setq begin (point))
            (forward-char 1)))
         ((char-equal ch close-delim)
          (setq ch (char-after))
          (if (not (and ch (char-equal ch close-delim)))
              (setq delims-unbalanced nil)
            (push (buffer-substring-no-properties begin (1- (point))) fragments)
            (setq begin (point))
            (forward-char 1)))))
      (when delims-unbalanced
        (error "Unbalanced delimiters %c%c in balanced string at char %d."
               open-delim close-delim (point)))
      (push (buffer-substring-no-properties begin (1- (point))) fragments)
      (if (null (cdr fragments))
          (car fragments)
        (apply 'concat (nreverse fragments)))))

  (defun tag-test-find-todo-query (query-string)
    "Does query string contain a todo match expression at the end? 
Search for the first / that is not between quotes or braces, and
return the index of that character if found, or nil.
Set match data for QUERY-STRING so that group 0 spans from the
found / to the end of the string, group 1 matches \"/!?\\s-*\" at
the found /, and group 2 matches the ! if present."
    (with-temp-buffer
      (insert query-string)
      (goto-char (point-min))
      ;; Search for first / that is not between ""'s or {}'s or ()'s
      (catch :found-slash
        (let ((paren-count 0))
          (while (re-search-forward "\\(/\\(!\\)?\\s-*\\)\\|[\"{()]" nil t)
            (when (and (zerop paren-count) (match-end 1))
              (set-match-data  
               (mapcar '1-         ; set indices using string convention
                       (nconc (list (match-beginning 0) (point-max) ;0 / to end
                                    (match-beginning 1) (match-end 1)) ;1 /!?\\s-*
                              (if (match-end 2) ;2 !?
                                  (list (match-beginning 2) (match-end 2))
                                nil))))
              (throw :found-slash (1- (match-beginning 1))))
            (goto-char (match-beginning 0))
            (case (char-after)
              (?\( (setq paren-count (1+ paren-count)) (forward-char))
              (?\) (setq paren-count (1- paren-count)) (forward-char))
              (?\" (read (current-buffer)))
              (?\{ (tag-test-read-balanced-string ?\{ ?\}))
              (?/  (forward-char)))))
        nil))))

(defun tag-test-transform (matcher)
  (let ((spec
         (if (and (eq (cadr matcher) 'and)
                  (eq (car (last matcher)) t))
             (cons (car matcher) (car (cddr matcher)))
           matcher)))
    (if (listp (cdr spec))
        (mapcar 'tag-test-transform-1 spec)
      spec)))

(defun tag-test-transform-1 (spec)
  (if (atom spec)
      spec
    (case (car spec)
      (and
       (cons 'and (nreverse (mapcar 'tag-test-transform-1 (cdr spec)))))
      (or
       (if (and (null (nthcdr 3 spec))
                (equal (car (cddr spec)) ""))
           spec
         (cons 'or (nreverse (mapcar 'tag-test-transform-1 (cdr spec))))))
      (not
       (if (eq (car (cadr spec)) 'string-match)
           (list 'org-string-match<>
                 (car (cddr (cadr spec)))
                 (cadr (cadr spec)))
         spec))
      (string-match
       (list 'org-string-match= (car (cddr spec)) (cadr spec)))
      (t
       (cons (tag-test-transform-1 (car spec))
             (mapcar 'tag-test-transform-1 (cdr spec)))))))

(defun tag-test-m (query &optional originalp)
  "Call `org-make-tags-matcher' on QUERY. 
New version by default, original version if ORIGINALP is non-nil."
  (let ((todo-only nil))
    (funcall
     (if originalp
         'org-make-tags-matcher-ORIGINAL
       'org-make-tags-matcher-NEW)
     query)))

(defun tag-test-parse-tree (query)
  "Return (just) the parse tree for query produced by `org-tag-query-parser'"
  (car (nthcdr 2 (org-tag-query-parse query))))
;; useful at repl: (defun tq (query) (cons query (tag-test-parse-tree query)))


(defun tag-test-compare (new original)
  (if (and (or (eq (cdr new) t) (eq (cadr new) 'progn))
           (eq (cadr original) 'and)
           (eq (car (last original)) t))
      (equal `(and ,(cdr new) t) (cdr original))
    (equal (cdr new) (cdr original))))
;; formerly returned (and __ (format "%s<==>%s" (car new) (car original)))

(defvar tag-test-suite-table (make-hash-table)
  "Mapping from test name symbols to tag test functions. Each
function takes an optional argument, which if non-nil, causes a
simple boolean summary to be returned. Otherwise, the function
returns the list of results forms. Call with `tag-test-run'
giving name and optional summarize argument.")

(defmacro tag-test-suite (name &rest body)
  "Register test NAME. If NAME is nil, do not save the test, run it
now with summarize argument t."
  (declare (indent 1))
  (flet ((test-it (spec)
                  (let ((query (car spec))
                        (obj   (cdr spec)))
                    (cond
                     ((null obj)
                      `(let ((todo-only nil)) ; needs to be scoped in
                         (condition-case exception
                             (cons
                              (equal
                               (org-make-tags-matcher-NEW ,query)
                               (tag-test-transform
                                (org-make-tags-matcher-ORIGINAL ,query)))
                              ,query)
                           (error (cons nil
                                        (format "ERROR on query %s: %s"
                                                ,query (cadr exception)))))))
                     ((stringp obj)
                      `(let ((todo-only nil)) ; needs to be scoped in
                         (condition-case exception
                             (cons
                              (tag-test-compare
                               (org-make-tags-matcher-NEW ,query)
                               (org-make-tags-matcher-ORIGINAL ,obj))
                              ,query)
                           (error (cons nil
                                        (format "ERROR on query %s: %s"
                                                ,query (cadr exception)))))))
                     ((eq obj 'error)
                      `(condition-case exception
                           (let ((todo-only nil)) ; needs to be scoped in
                             (org-make-tags-matcher-NEW ,query)
                             (cons nil ,query))
                         (error (cons (cadr exception) ,query))))
                     ((eq obj t)
                      `(condition-case exception
                           (cons
                            (equal (tag-test-m ,query)
                                   '(,query . t))
                            ,query)
                         (error (cons nil
                                        (format "ERROR on query %s: %s"
                                                ,query (cadr exception))))))
                     ((and (consp obj)
                           (tag-test-find-todo-query query))
                      `(condition-case exception
                           (cons
                            (equal (tag-test-m ,query)
                                   ',(cons query (car obj)))
                            ,query)
                         (error (cons nil
                                        (format "ERROR on query %s: %s"
                                                ,query (cadr exception))))))
                     ((consp obj)
                      `(condition-case exception
                           (cons
                            (equal (tag-test-m ,query)
                                   '(,query progn
                                            (setq org-cached-props nil)
                                            ,(car obj)))
                            ,query)
                         (error (cons nil
                                        (format "ERROR on query %s: %s"
                                                ,query (cadr exception))))))
                     (t (error "Unrecognized test type"))))))
    (let* ((result-forms (mapcar 'test-it body))
           (test `(lambda (&optional summarize?)
                    (let ((tests (list ,@result-forms)))
                      (if summarize?
                          (let ((outcome (catch :failure
                                           (dolist (result tests t)
                                             (unless (car result)
                                               (throw :failure nil))))))
                            (if outcome
                                (message "All %s tests passed." ',name)
                              (message "Some %s tests failed." ',name))
                            outcome)
                        (list ,@result-forms))))))
      (if name
          `(progn (puthash ',name ,test tag-test-suite-table) t)
        `(funcall ,test t)))))

(defun tag-test-run (summarize? &rest suite-symbols)
  (let ((summarize (and summarize?
                        (not (memq summarize? '(:show :results :result)))))
        (results nil)
        (suites (if suite-symbols
                    suite-symbols
                  (loop for key being the hash-keys of tag-test-suite-table
                        collect key))))
    (dolist (suite suites)
      (condition-case except
          (let ((test (gethash suite tag-test-suite-table)))
            (if (and test (functionp test))
                (push (cons suite (funcall test summarize)) results)
              (push (cons suite
                          (cons nil (format "Test suite %s not found" suite)))
                    results)))
        (error (push (format "Uncaught error on suite %s: %s"
                             suite except)
                     results))))
    (if (cdr results) (nreverse results) (car results))))


;;; The Test Suites

(tag-test-suite simple-tag-matchers-1
  ("")
  ("foo")
  ("-foo")
  ("foo+bar")
  ("foo-bar")
  ("-foo+bar")
  ("-foo-bar")
  ("{^HU+RRAY}")
  ("-{^BO*O!}")
  ("foo+bar+zap")
  ("foo-bar+zap")
  ("-foo+bar-zap")
  ("foo|bar|-zap")
  ("-foo+bar+zap-{^a.*}")
  ("-{^abc}+{^a}")
  ("{^A}|{^.B}|{^C}")
  ("{^A}|ok-zap|{^C}"))

(tag-test-suite level-comparisons
  ("LEVEL<3")
  ("LEVEL>3")
  ("LEVEL<=3")
  ("LEVEL>=3")
  ("LEVEL=3")
  ("LEVEL<>3")
  ("LEVEL>4|LEVEL<3")
  ("zap+LEVEL=3")
  ("zap+LEVEL>2-bar")
  ("-{[0-9]}|zap9@#%it|LEVEL>5")
  ("xyz&LEVEL<>3|{^a}-abc&LEVEL<>3")
  ("zap-bar+foo&LEVEL>2"))

(tag-test-suite property-string-comparisons
  ("A_PROP<\"foo\"")
  ("A_PROP>\"foo\"")
  ("A_PROP<=\"foo\"")
  ("A_PROP>=\"foo\"")
  ("A_PROP<>\"foo\"")
  ("A_PROP=\"foo\"")
  ("A_PROP<>{^f.*o}")
  ("A_PROP={^f.*o}")
  ("foo+PROP=\"A\"+Z={abc}-bar"))

(tag-test-suite property-date-comparisons
  ("A_DATE=\"<2008-12-24 18:30>\"")
  ("A_DATE<\"<2008-12-24 18:30>\"")
  ("A_DATE<=\"<2008-12-24 18:30>\"")
  ("A_DATE>=\"<2008-12-24 18:30>\"")
  ("A_DATE>\"<2008-12-24 18:30>\"")
  ("A_DATE<>\"<2008-12-24 18:30>\"")
  ("DEADLINE<>\"<-2d>\"")
  ("DEADLINE=\"<+1w>\"")
  ("DEADLINE>\"<+60m>\"")
  ("DEADLINE<\"<today>\"")
  ("SCHEDULED>=\"<tomorrow>\"")
  ("SCHEDULED<=\"<+2y>\""))

(tag-test-suite property-numeric-comparisons
  ("Effort<3")
  ("Effort>3")
  ("Effort<=3")
  ("Effort>=3")
  ("Effort=3")
  ("Effort<>3")
  ("Effort>4|Effort<3")
  ("strength>-1.0&effort<4&foo>1.7e10")
  ("A>4|B<10")
  ("A>4.0&B<.4&C<>1e5"))

(tag-test-suite todo-category-comparisons
  ("TODO=\"WAIT\"")
  ("TODO<>\"WAIT\"")
  ("TODO={^W}")
  ("TODO<>{^W}")
  ("CATEGORY=\"foo\"")
  ("CATEGORY<>\"foo\"")
  ("CATEGORY={^f}")
  ("CATEGORY<>{^f}")
  ("work+TODO=\"WAITING\"|home+TODO=\"WAITING\"")
  ("work-TODO=\"WAITING\"|home&TODO=\"WAITING\""))

(tag-test-suite combined-matchers-1
  ("-zap+bar|LEVEL<=2&TODO<>\"WAIT\"")
  ("+work-boss+PRIORC=\"A\"+Coffee=\"unlimited\"+Effort<2+With={Sarah\\|Denny}+SCHEDULED>=\"<2008-10-11>\"")
  ("foo-xyz&X>2.0|Y<3.0")
  ("foo-bar|SCHEDULED=\"<2012-07-01>\"|TODO=\"URGENT\"")
  ("xyz&LEVEL<>3|{^a}-abc&A_PROP<>\"foo\"|A_PROP=\"foo\"")
  ("-a|a&LEVEL=4|a&A_PROP<>{^foo}"))

;; Some of these are the same as above, but I've explicitly reversed
;; the terms to make sure that the transformer is not masking any problems.
;; This necessarily excludes the other transformations so it is really a meta-test.
;; The rest include todo matchers in the comparison.
(tag-test-suite check-matchers
  ("foo+bar+zap" . "zap+bar+foo")
  ("foo-bar+zap" . "zap-bar+foo")
  ("-foo+bar-zap" . "-zap+bar-foo")
  ("foo|bar|-zap" . "-zap|bar|foo")
  ("-foo+bar+zap-{^a.*}" . "-{^a.*}+zap+bar-foo")
  ("-{^abc}+{^a}" . "{^a}-{^abc}")
  ("-{[0-9]}|zap9@#%it|LEVEL>5" . "LEVEL>5|zap9@#%it|-{[0-9]}")
  ("{^A}|{^.B}|{^C}" . "{^C}|{^.B}|{^A}")
  ("{^A}|ok-zap|{^C}" . "{^C}|-zap+ok|{^A}")
  ("work+TODO=\"WAITING\"|home+TODO=\"WAITING\"" . "TODO=\"WAITING\"+home|TODO=\"WAITING\"+work")
  ("work-TODO=\"WAITING\"|home&TODO=\"WAITING\"" . "TODO=\"WAITING\"&home|-TODO=\"WAITING\"+work")
  ("zap -bar   +foo & LEVEL > 2" . "LEVEL>2&foo-bar+zap")
  ("-zap+bar | LEVEL <= 2 & TODO <> \"WAIT\"" . "TODO<>\"WAIT\"&LEVEL<=2|bar-zap"))

(tag-test-suite todo-matchers-1
  ("foo+bar/TODO+WAIT-DONE"
   (and
    (progn
      (setq org-cached-props nil)
      (and
       (member "foo" tags-list)
       (member "bar" tags-list)))
    (equal todo "TODO")
    (equal todo "WAIT")
    (not (equal todo "DONE"))))
  ("foo+bar/TODO+WAIT|URGENT" 
   (and
    (progn
      (setq org-cached-props nil)
      (and
       (member "foo" tags-list)
       (member "bar" tags-list)))
    (or
     (and
      (equal todo "TODO")
      (equal todo "WAIT"))
     (equal todo "URGENT"))))
  ("/A" (and t (equal todo "A")))
  ("/A-{AIT}" 
   (and t
        (equal todo "A")
        (org-string-match<> (or todo "") "AIT")))
  ("foo-bar/A+B|C-D|{W+}" 
   (and
    (progn
      (setq org-cached-props nil)
      (and
       (member "foo" tags-list)
       (not (member "bar" tags-list))))
    (or
     (and
      (equal todo "A")
      (equal todo "B"))
     (and
      (equal todo "C")
      (not (equal todo "D")))
     (org-string-match= (or todo "") "W+"))))
  ("-abc+uvw-xyz/{^T}+WAIT-DONE|URGENT|{^I}-IGNORE" 
   (and
    (progn
      (setq org-cached-props nil)
      (and
       (not (member "abc" tags-list))
       (member "uvw" tags-list)
       (not (member "xyz" tags-list))))
    (or
     (and
      (org-string-match= (or todo "") "^T")
      (equal todo "WAIT")
      (not (equal todo "DONE")))
     (equal todo "URGENT")
     (and
      (org-string-match= (or todo "") "^I")
      (not (equal todo "IGNORE"))))))
  ("-(-abc+uvw-xyz/{^T}+WAIT-DONE|URGENT|{^I}-IGNORE)" 
   (not (and
         (and
          (not (member "abc" tags-list))
          (member "uvw" tags-list)
          (not (member "xyz" tags-list)))
         (or
          (and
           (org-string-match= (or todo "") "^T")
           (equal todo "WAIT")
           (not (equal todo "DONE")))
          (equal todo "URGENT")
          (and
           (org-string-match= (or todo "") "^I")
           (not (equal todo "IGNORE")))))))
  ("-zap+bar|LEVEL<=2&TODO<>\"WAIT\"/OK-NOT|GOOD-BAD|HURRAY-BOO"))

(tag-test-suite todo-matchers-2
  ("-(/{\\S-})|HEADING={Up}"
   (or
    (not
     (and t
          (org-string-match= (or todo "") "\\S-")))
    (org-string-match= (or heading "") "Up")))
  ("/{\\S-}" (and t (org-string-match= (or todo "") "\\S-")))
  ("-(/TODO)|(HEADING={Up}/TODO)"
   (or
    (not (and t (equal todo "TODO")))
    (and
     (org-string-match= (or heading "") "Up")
     (equal todo "TODO"))))
  ("-(foo+bar-zap/TODO+WAIT)"
   (not (and (and
              (member "foo" tags-list)
              (member "bar" tags-list)
              (not (member "zap" tags-list)))
             (equal todo "TODO")
             (equal todo "WAIT"))))
  ("-(foo|bar|zap/TODO|WAIT)"
   (not (and (or
              (member "foo" tags-list)
              (member "bar" tags-list)
              (member "zap" tags-list))
             (or
              (equal todo "TODO")
              (equal todo "WAIT")))))
  ("-(foo|bar|(zap&LEVEL>2)/TODO|{^W}-WAIT)"
   (not (and
         (or
          (member "foo" tags-list)
          (member "bar" tags-list)
          (and (member "zap" tags-list)
               (> level 2)))
         (or
          (equal todo "TODO")
          (and
           (org-string-match= (or todo "") "^W")
           (not (equal todo "WAIT")))))))
  ("foo|bar|zap&LEVEL>2/TODO|{^W}-WAIT" 
   (and
    (progn
      (setq org-cached-props nil)
      (or
       (member "foo" tags-list)
       (member "bar" tags-list)
       (and
        (member "zap" tags-list)
        (> level 2))))
    (or
     (equal todo "TODO")
     (and
      (org-string-match= (or todo "") "^W")
      (not (equal todo "WAIT")))))))

(tag-test-suite fancy-matchers-1
  ("LEVEL == 2 & HEADING <> {<.*>} & PRIORITY <> \"A\" "
   (and
    (= level 2)
    (org-string-match<> (or heading "") "<.*>")
    (org-string<> (or priority "") "A")))
  ("(xyz|{^a}-abc) & LEVEL > 1"
   (and
    (or (member "xyz" tags-list)
        (and
         (org-match-any-p "^a" tags-list)
         (not (member "abc" tags-list))))
    (> level 1)))
  ("-((xyz|{^a}-abc) & LEVEL > 1)"
   (not (and
         (or (member "xyz" tags-list)
             (and
              (org-match-any-p "^a" tags-list)
              (not (member "abc" tags-list))))
         (> level 1))))
  ("HEADING == {Z\\{{3,7\\}}} & TODO<>\"TODO\"" 
   (and
    (org-string-match= (or heading "") "Z\\{3,7\\}")
    (org-string<> (or todo "") "TODO")))
  ("((a-b+{^[c-g]})-(d+LEVEL>2))|{^z}&LEVEL=5&-(A_PROP=\"foo\"|B_PROP=\"bar\")"
   (or
    (and
     (and
      (member "a" tags-list)
      (not (member "b" tags-list))
      (org-match-any-p "^[c-g]" tags-list))
     (not
      (and
       (member "d" tags-list)
       (> level 2))))
    (and
     (org-match-any-p "^z" tags-list)
     (= level 5)
     (not
      (or
       (string= (or (org-cached-entry-get nil "A_PROP") "") "foo")
       (string= (or (org-cached-entry-get nil "B_PROP") "") "bar")))))))

;; some of the / todo matches are practically silly, but testing structure here
(tag-test-suite fancy-matchers-2
  ("" . t)
  ("           /!" 
   (and (member todo org-not-done-keywords) t))
  ("           /!              " 
   (and (member todo org-not-done-keywords) t))
  ("A_PROP={^0x[0-9A-F]+}"
   (org-string-match=
    (or (org-cached-entry-get nil "A_PROP") "") "^0x[0-9A-F]+"))
  ("A_PROP<>{^[A-Z]+}"
   (org-string-match<>
    (or (org-cached-entry-get nil "A_PROP") "") "^[A-Z]+"))
  ("(a+b-c|A_PROP==2|-(d-e+f&LEVEL>3))"
   (or
    (and
     (member "a" tags-list)
     (member "b" tags-list)
     (not (member "c" tags-list)))
    (= (string-to-number (or (org-cached-entry-get nil "A_PROP") "")) 2)
    (not (and
          (member "d" tags-list)
          (not (member "e" tags-list))
          (member "f" tags-list)
          (> level 3)))))
  ("((c))" (member "c" tags-list))
  ("((-(((-(c))))))" (member "c" tags-list))
  ("((-(-((-(c))))))" (not (member "c" tags-list)))
  ("-(zap -bar   +foo & LEVEL > 2 | HEADING == {Z{{3,7}}})"
   (not (or (and
             (member "zap" tags-list)
             (not (member "bar" tags-list))
             (member "foo" tags-list)
             (> level 2))
            (org-string-match= (or heading "") "Z{3,7}"))))
  ("zap -bar   +foo & LEVEL > 2" 
   (and 
    (member "zap" tags-list)
    (not (member "bar" tags-list))
    (member "foo" tags-list)
    (> level 2)))
  ("-zap+bar | LEVEL <= 2 & TODO <> \"WAIT\"" 
   (or
    (and
     (not (member "zap" tags-list))
     (member "bar" tags-list))
    (and
     (<= level 2)
     (org-string<> (or todo "")  "WAIT"))))
  ("-(zap|{^A}|LEVEL=2)"
   (not (or
         (member "zap" tags-list)
         (org-match-any-p "^A" tags-list)
         (= level 2))))
  ("/!TODO"
   (and
    (member todo org-not-done-keywords)
    t
    (equal todo "TODO")))
  ("/TODO"
   (and t (equal todo "TODO")))
  ("/!"
   (and (member todo org-not-done-keywords) t))
  ("abc-uvw+xyz/!TODO"
   (and
    (member todo org-not-done-keywords)
    (progn
      (setq org-cached-props nil)
      (and
       (member "abc" tags-list)
       (not (member "uvw" tags-list))
       (member "xyz" tags-list)))
    (equal todo "TODO")))
  ("abc-uvw+xyz+LEVEL<=3/TODO|HOLDING-WAITING|AVOIDING-REALLY_AVOIDING" 
   (and
    (progn
      (setq org-cached-props nil)
      (and
       (member "abc" tags-list)
       (not (member "uvw" tags-list))
       (member "xyz" tags-list)
       (<= level 3)))
    (or
     (equal todo "TODO")
     (and
      (equal todo "HOLDING")
      (not (equal todo "WAITING")))
     (and
      (equal todo "AVOIDING")
      (not (equal todo "REALLY_AVOIDING"))))))
  ("abc-uvw+xyz+LEVEL<=3/!TODO|HOLDING-WAITING|AVOIDING-REALLY_AVOIDING"
   (and
    (member todo org-not-done-keywords)
    (progn
      (setq org-cached-props nil)
      (and
       (member "abc" tags-list)
       (not (member "uvw" tags-list))
       (member "xyz" tags-list)
       (<= level 3)))
    (or
     (equal todo "TODO")
     (and
      (equal todo "HOLDING")
      (not (equal todo "WAITING")))
     (and
      (equal todo "AVOIDING")
      (not (equal todo "REALLY_AVOIDING"))))))
  ("abc-uvw+xyz+LEVEL<=3/!TODO|{Y}-{Z}|{A}-{B}"
   (and
    (member todo org-not-done-keywords)
    (progn
      (setq org-cached-props nil)
      (and
       (member "abc" tags-list)
       (not (member "uvw" tags-list))
       (member "xyz" tags-list)
       (<= level 3)))
    (or
     (equal todo "TODO")
     (and
      (org-string-match= (or todo "") "Y")
      (org-string-match<> (or todo "") "Z"))
     (and
      (org-string-match= (or todo "") "A")
      (org-string-match<> (or todo "") "B")))))
  ("PROP={^\\s-*// .*$}/A{}B"
   (and
    (progn
      (setq org-cached-props nil)
      (org-string-match= (or (org-cached-entry-get nil "PROP") "")
                         "^\\s-*// .*$"))
    (equal todo "A")
    (org-string-match= (or todo "") "")
    (equal todo "B"))) ; See Note h for why the current 7.8 code does not work for this case
  ("PROP={^\\s-*// .*$}/A+{^.*ab$}+B" 
   (and
    (progn
      (setq org-cached-props nil)
      (org-string-match= (or (org-cached-entry-get nil "PROP") "")
                         "^\\s-*// .*$"))
    (equal todo "A")
    (org-string-match= (or todo "") "^.*ab$")
    (equal todo "B")))
  ("PROP={^\\s-*// .*$}/A+{^.*ab{{1,3}}$}+B" 
   (and
    (progn
      (setq org-cached-props nil)
      (org-string-match= (or (org-cached-entry-get nil "PROP") "")
                         "^\\s-*// .*$"))
    (equal todo "A")
    (org-string-match= (or todo "") "^.*ab{1,3}$")
    (equal todo "B")))
  ("PROP={^\\s-*// .*$}/A-{^.*ab$}-B|-C+{^c*$}" 
   (and
    (progn
      (setq org-cached-props nil)
      (org-string-match= (or (org-cached-entry-get nil "PROP") "") 
                         "^\\s-*// .*$"))
    (or
     (and
      (equal todo "A")
      (org-string-match<> (or todo "") "^.*ab$")
      (not (equal todo "B")))
     (and
      (not (equal todo "C"))
      (org-string-match= (or todo "") "^c*$")))))
  ("/!A" 
   (and
    (member todo org-not-done-keywords)
    t
    (equal todo "A")))
  ("foo+bar/!TODO+WAIT-DONE" 
   (and
    (member todo org-not-done-keywords)
    (progn
      (setq org-cached-props nil)
      (and
       (member "foo" tags-list)
       (member "bar" tags-list)))
    (equal todo "TODO")
    (equal todo "WAIT")
    (not (equal todo "DONE"))))
  ("foo+bar/!TODO+WAIT|URGENT"
   (and
    (member todo org-not-done-keywords)
    (progn
      (setq org-cached-props nil)
      (and
       (member "foo" tags-list)
       (member "bar" tags-list)))
    (or
     (and
      (equal todo "TODO")
      (equal todo "WAIT"))
     (equal todo "URGENT"))))
  ("foo+bar/!TODO|WAIT|URGENT"
   (and
    (member todo org-not-done-keywords)
    (progn
      (setq org-cached-props nil)
      (and
       (member "foo" tags-list)
       (member "bar" tags-list)))
    (or
     (equal todo "TODO")
     (equal todo "WAIT")
     (equal todo "URGENT"))))  
  ("foo+bar/!{TODO}-WAIT"
   (and
    (member todo org-not-done-keywords)
    (progn
      (setq org-cached-props nil)
      (and
       (member "foo" tags-list)
       (member "bar" tags-list)))
    (org-string-match= (or todo "") "TODO")
    (not (equal todo "WAIT")))))

(tag-test-suite fancy-matchers-3
  ("((a +b -c & LEVEL > 2 | c & LEVEL == 1)-(HEADING={<NOTES>}|TODO=\"DONE\")|urgent|_queue&DEADLINE>\"<2012-01-01 04:00>\")"
   (or
    (and
     (or (and
          (member "a" tags-list)
          (member "b" tags-list)
          (not (member "c" tags-list))
          (> level 2))
         (and
          (member "c" tags-list)
          (= level 1)))
     (not
      (or (org-string-match= (or heading "") "<NOTES>")
          (string= (or todo "") "DONE"))))
    (member "urgent" tags-list)
    (and
     (member "_queue" tags-list)
     (org-time> (or (org-cached-entry-get nil "DEADLINE") "") 1325394000.0))))
  ("+you+me-them&PRIORITY==\"A\"+CATEGORY<>\"missing\""
   (and
    (member "you" tags-list)
    (member "me" tags-list)
    (not (member "them" tags-list))
    (string= (or priority "") "A")
    (org-string<>
     (or (get-text-property (point) 'org-category) "") "missing")))
  ("+you+me-them & PRIORITY == \"A\" + CATEGORY <> \"missing\""
   (and
    (member "you" tags-list)
    (member "me" tags-list)
    (not (member "them" tags-list))
    (string= (or priority "") "A")
    (org-string<> (or (get-text-property (point) 'org-category) "") "missing")))
  ("+you+me-them & PRIORITY < \"A\" | CATEGORY <> \"missing\" + us | HEADING={\\(?:[Ss]ecret\\){{1,3}}}"
   (or
    (and
     (member "you" tags-list)
     (member "me" tags-list)
     (not (member "them" tags-list))
     (string< (or priority "") "A"))
    (and
     (org-string<> (or (get-text-property (point) 'org-category) "")
                   "missing")
     (member "us" tags-list))
    (org-string-match= (or heading "") "\\(?:[Ss]ecret\\){1,3}")))
  ("PROP\\-WITH\\-HYPHENS=2"
   (=
    (string-to-number
     (or
      (org-cached-entry-get nil "PROP-WITH-HYPHENS")
      ""))
    2))
  ("PROP={^\\s-*// .*$}"
   (org-string-match=
    (or (org-cached-entry-get nil "PROP") "")
    "^\\s-*// .*$"))
  ("work-TODO=\"WAITING\"|home&TODO=\"WAITING\"/!" 
   (and
    (member todo org-not-done-keywords)
    (progn
      (setq org-cached-props nil)
      (or
       (and
        (member "work" tags-list)
        (not (string= (or todo "") "WAITING")))
       (and
        (member "home" tags-list)
        (string= (or todo "") "WAITING")))))))

(tag-test-suite should-error-1
  ("()" . error) ; we might just do t here, but the parens suggest an error
  ("(&foo+LEVEL=1)" . error)
  ("(foo+LEVEL=1" . error)
  ("(foo+LEVEL=1))" . error)
  ("(abc+)" . error)
  ("abc+xyz!" . error)
  ("(missing+paren" . error)            
  ("PROP={.*closing brace?" . error) 
  ("PROP=\"abc" . error)
  ("P<<2-bad+cmp+op" . error)
  ("P<={^foo}" . error)
  ("PROP<-.dx" . error)           ; bad number
  ("!?;" . error)
  ("   [x]" . error)
  ("(foo+bar/TODO" . error)
  ("(foo+bar)+/TODO" . error)
  ("foo+bar/!TODO|{AC" . error)
  ("(((foo))))/TODO" . error)
  ("foo+" . error)
  ("foo/TODO-" . error)
  ("-(foo+bar/+)" . error)
  ("-(foo+bar/A-B())" . error))

;;; Miscellaneous Other tests -- really need a complete framework here.

(defun tqs (q)
  (let ((todo-only nil))
    (cdr (org-make-tags-matcher-NEW q))))

(defun tag-test-scan (s point-list &optional stay-put)
  (prog1
      (if (atom point-list)
          (org-scan-tags-NEW 'point (tqs s) nil)
        (cons (equal (org-scan-tags-NEW 'point (tqs s) nil) point-list) s))
    (unless stay-put
      (goto-char (point-min)))))

(defun tag-test-do-scan-tests-1 (tests func)
  (let ((contents
         "* [#B] A heading One                                                       :xyz:
** Put a One here too at level Two
*** And a level Three, also One   
* [#C] B heading Two                                                       :uvw:
** Another                                                                 :abc:
* [#A] C heading Three                                                     :xyz:
* <NOTES>                                                                  :wtf:
** More more more
*** TODO Onward
*** TODO Upward
*** WATT What comes up...
*** DONE Gliding home
**** Just a test    
* [#A] D heading Four                                                      :uvw:
* TODO E heading Five                                              :abc:uvw:xyz:
  SCHEDULED: <2012-07-31 Tue>
** Answers
   + xyz: 1 314 676
   + xyz-abc: 1 314  
   + Priority A: 314 595
   + Priority not empty: 1 152 314 595
   + Priority empty, Level 1: 395 676
   + Scheduled after <2012-07-01 00:00>: 676
   + TODO=\"TODO\": 494 510 676
   + TODO=\"TODO\", Level>1: 494 510
   + HEADING={<.*>}: 395
   + HEADING={One\\|Two}, Level <= 2: 1 82 152
"))
    (with-temp-buffer
      (set (make-local-variable 'org-tags-column) -80)
      (set (make-local-variable 'org-todo-keywords)
           '((sequence "TODO" "WAIT" "DONE")))
      (org-mode)
      (insert contents)
      (goto-char (point-min))
      (mapcar func tests))))

(defun tag-test-other-tests (&optional summarize?)
  (let ((summarize (and summarize?
                        (not (memq summarize? '(:show :results :result)))))
        (all (lambda (x)
               (catch :done
                 (dolist (item x t)
                   (when (null (car item)) (throw :done nil))))))
        (results
         (list
          ;; Testing that the matchers work with org-scan-tags
          (let ((scan-tests '(("xyz+LEVEL=1" 1 314 676)
                              ("xyz-abc+LEVEL=1" 1 314)
                              ("xyz" 1 82 117 314 676 787)
                              ("xyz-abc" 1 82 117 314)
                              ("HEADING={<.*>}" 395)
                              ("HEADING={One\\|Two} & LEVEL <= 2" 1 82 152)
                              ("PRIORITY=\"A\"" 314 595)
                              ("PRIORITY<>\"\"" 1 152 314 595)
                              ("PRIORITY=\"\" + LEVEL == 1" 395 676)
                              ("SCHEDULED>=\"<2012-07-01 00:00>\"" 676)
                              ("TODO=\"TODO\"" 494 510 676)
                              ("TODO=\"TODO\"  & LEVEL > 1" 494 510)
                              ("wtf/TODO" 494 510)
                              ("-wtf/TODO" 676)
                              ("-(wtf/TODO)" 1 82 117 152 233 314 395 476 526 552 574 595 676 787)
                              ("-(/TODO)|(HEADING={Up}/TODO)" 1 82 117 152 233 314 395 476 510 526 552 574 595 787)
                              ("-(/{\\S-})|HEADING={Up}" 1 82 117 152 233 314 395 476 510 526 574 595 787))))
            (cons 'org-scan-tags-1
                  (tag-test-do-scan-tests-1
                   scan-tests '(lambda (v) (tag-test-scan (car v) (cdr v))))))
          ;; Testing that the matchers work with org-map-entries
          (let ((scan-tests '(("xyz+LEVEL=1" 1 314 676)
                              ("xyz-abc+LEVEL=1" 1 314)
                              ("xyz" 1 82 117 314 676 787)
                              ("xyz-abc" 1 82 117 314)
                              ("HEADING={<.*>}" 395)
                              ("HEADING={One\\|Two} & LEVEL <= 2" 1 82 152)
                              ("PRIORITY=\"A\"" 314 595)
                              ("PRIORITY<>\"\"" 1 152 314 595)
                              ("PRIORITY=\"\" + LEVEL == 1" 395 676)
                              ("SCHEDULED>=\"<2012-07-01 00:00>\"" 676)
                              ("TODO=\"TODO\"" 494 510 676)
                              ("TODO=\"TODO\"  & LEVEL > 1" 494 510)
                              ("wtf/TODO" 494 510)
                              ("-wtf/TODO" 676)
                              ("-(wtf/TODO)" 1 82 117 152 233 314 395 476 526 552 574 595 676 787)
                              ("-(/TODO)|(HEADING={Up}/TODO)" 1 82 117 152 233 314 395 476 510 526 552 574 595 787)
                              ("-(/{\\S-})|HEADING={Up}" 1 82 117 152 233 314 395 476 510 526 574 595 787))))
            (cons 'org-map-entries-1
                  (tag-test-do-scan-tests-1
                   scan-tests '(lambda (v)
                                 (cons (equal (org-map-entries 'point (car v)) (cdr v))
                                       (car v)))))))))
    (if summarize
        (mapcar (lambda (suite) (cons (car suite) (funcall all (cdr suite))))
                results)
      results)))


(provide 'tag-query-tests)

;;; tag-query-tests.el ends here

^ permalink raw reply	[flat|nested] only message in thread

only message in thread, other threads:[~2012-08-16  4:01 UTC | newest]

Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2012-08-16  4:00 new tag query parser [3/5] -- the code and how to use it (code attached) Christopher Genovese

Code repositories for project(s) associated with this inbox:

	https://git.savannah.gnu.org/cgit/emacs/org-mode.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).