xml-query.el

;;; xml-query.el --- query engine complimenting the xml package

;; This is free and unencumbered software released into the public domain.

;;; Commentary:

;; This provides a very rudimentary, jQuery-like, XML selector
;; s-expression language. It operates on the output of the xml
;; package, such as `xml-parse-region' and `xml-parse-file'. It was
;; written to support Elfeed.

;; See the docstring for `xml-query-all'.

;; The macro forms, `xml-query*' and `xml-query-all*', are an order of
;; magnitude faster, but only work on static selectors and need the
;; namespaces to be pre-stripped.

;; Examples:

;; This query grabs the top-level paragraph content from XHTML.

;;  (xml-query-all '(html body p *) xhtml)

;; This query extracts all the links from an Atom feed.

;;  (xml-query-all '(feed entry link [rel "alternate"] :href) xml)

;;; Code:

(require 'cl-lib)

(defun xml-query-strip-ns (tag)
  "Remove the namespace, if any, from TAG."
  (when (symbolp tag)
    (let ((name (symbol-name tag)))
      (if (cl-find ?\: name)
          (intern (replace-regexp-in-string "^.+:" "" name))
        tag))))

(defun xml-query--tag-all (match xml)
  (cl-loop for (tag attribs . content) in (cl-remove-if-not #'listp xml)
           when (or (eq tag match) (eq (xml-query-strip-ns tag) match))
           collect (cons tag (cons attribs content))))

(defun xml-query--attrib-all (attrib value xml)
  (cl-loop for (tag attribs . content) in (cl-remove-if-not #'listp xml)
           when (equal (cdr (assoc attrib attribs)) value)
           collect (cons tag (cons attribs content))))

(defun xml-query--keyword (matcher xml)
  (cl-loop with match = (intern (substring (symbol-name matcher) 1))
           for (tag attribs . content) in (cl-remove-if-not #'listp xml)
           when (cdr (assoc match attribs))
           collect it))

(defun xml-query--symbol (matcher xml)
  (xml-query--tag-all matcher xml))

(defun xml-query--vector (matcher xml)
  (let ((attrib (aref matcher 0))
        (value (aref matcher 1)))
    (xml-query--attrib-all attrib value xml)))

(defun xml-query--list (matchers xml)
  (cl-loop for matcher in matchers
           append (xml-query-all (if (listp matcher)
                                     matcher
                                   (list matcher)) xml)))

(defun xml-query--append (xml)
  (cl-loop for (tag attribs . content) in (cl-remove-if-not #'listp xml)
           append content))

(defun xml-query--stringp (thing)
  "Return non-nil of THING is a non-blank string."
  (and (stringp thing) (string-match "[^ \t\r\n]" thing)))

(defun xml-query-all (query xml)
  "Given a list of tags, XML, apply QUERY and return a list of
matching tags.

A query is a list of matchers.
 - SYMBOL: filters to matching tags
 - LIST: each element is a full sub-query, whose results are concatenated
 - VECTOR: filters to tags with matching attribute, [tag attrib value]
 - KEYWORD: filters to an attribute value (must be last)
 - * (an asterisk symbol): filters to content strings (must be last)

For example, to find all the 'alternate' link URL in a typical
Atom feed:

  (xml-query-all '(feed entry link [rel \"alternate\"] :href) xml)"
  (if (null query)
      xml
    (cl-destructuring-bind (matcher . rest) query
      (cond
       ((keywordp matcher) (xml-query--keyword matcher xml))
       ((eq matcher '*)
        (cl-remove-if-not #'xml-query--stringp (xml-query--append xml)))
       (:else
        (let ((matches
               (cl-etypecase matcher
                 (symbol (xml-query--symbol matcher xml))
                 (vector (xml-query--vector matcher xml))
                 (list   (xml-query--list   matcher xml)))))
          (cond
           ((null rest) matches)
           ((and (or (symbolp (car rest))
                     (listp (car rest)))
                 (not (keywordp (car rest)))
                 (not (eq '* (car rest))))
            (xml-query-all (cdr query) (xml-query--append matches)))
           (:else (xml-query-all rest matches)))))))))

(defun xml-query (query xml)
  "Like `xml-query-all' but only return the first result."
  (let ((result (xml-query-all query xml)))
    (if (xml-query--stringp result)
        result
      (car (xml-query-all query xml)))))

;; Macro alternatives:

;; This is a slightly less capable alternative with significantly
;; better performance (x10 speedup) that requires a static selector.
;; The selector is compiled into Lisp code via macro at compile-time,
;; which is then carried through to byte-code by the compiler. In
;; byte-code form, the macro performs no function calls other than
;; `throw' in the case of `xml-query*', where it's invoked less than
;; once per evaluation (only on success).

;; Queries are compiled tail-to-head with a result handler at the
;; deepest level. The generated code makes multiple bindings of the
;; variable "v" as it dives deeper into the query, using the layers of
;; bindings as a breadcrumb stack.

;; For `xml-query*', which has a single result, the whole expression
;; is wrapped in a catch, and the first successful match is thrown to
;; it from the result handler.

;; For `xml-query-all*', the result is pushed into an output list.

(defun xml-query--compile-tag (tag subexp subloop-p)
  `(when (and (consp v) (eq (car v) ',tag))
     ,(if subloop-p
          `(dolist (v (cddr v))
             ,subexp)
        subexp)))

(defun xml-query--compile-attrib (pair subexp subloop-p)
  `(let ((value (cdr (assq ',(aref pair 0) (cadr v)))))
     (when (equal value ,(aref pair 1))
       ,(if subloop-p
            `(dolist (v (cddr v))
               ,subexp)
          subexp))))

(defun xml-query--compile-keyword (keyword subexp)
  (let ((attrib (intern (substring (symbol-name keyword) 1))))
    `(let ((v (cdr (assq ',attrib (cadr v)))))
       (when v
         ,subexp))))

(defun xml-query--compile-star (subexp)
  `(when (and (stringp v) (string-match "[^ \t\r\n]" v))
     ,subexp))

(defun xml-query--compile-top (query input subexp)
  (let* ((rquery (reverse query))
         (prev nil))
    (while rquery
      (let ((matcher (pop rquery))
            ;; Should the next item loop over its children?
            (subloop-p (and (not (null prev))
                            (not (keywordp prev))
                            (symbolp prev))))
        (cond
         ((eq '* matcher)
          (setf subexp (xml-query--compile-star subexp)))
         ((keywordp matcher)
          (setf subexp (xml-query--compile-keyword matcher subexp)))
         ((symbolp matcher)
          (setf subexp (xml-query--compile-tag matcher subexp subloop-p)))
         ((vectorp matcher)
          (setf subexp (xml-query--compile-attrib matcher subexp subloop-p)))
         ((error "Bad query: %S" query)))
        (setf prev matcher)))
    `(dolist (v ,input)
       ,subexp)))

(defun xml-query--compile (query input)
  (let ((tag (make-symbol "done")))
    `(catch ',tag
       ,(xml-query--compile-top query input `(throw ',tag v)))))

(defmacro xml-query* (query sexp)
  "Like `xml-query' but generate code to execute QUERY on SEXP.

Unlike `xml-query', QUERY must be a static, compile-time
s-expression. See `xml-query-all*' for more information.

QUERY is *not* evaluated, so it should not be quoted."
  (xml-query--compile query sexp))

(defun xml-query-all--compile (query input)
  (let ((output (make-symbol "output")))
    `(let ((,output ()))
       ,(xml-query--compile-top query input `(push v ,output))
       (nreverse ,output))))

(defmacro xml-query-all* (query sexp)
  "Like `xml-query-all' but generate code to execute QUERY on SEXP.

Unlike `xml-query-all', QUERY must be a static, compile-time
s-expression. This macro compiles the query into actual code. The
result is faster since the query will be compiled into byte-code
rather than \"interpreted\" at run time.

Also unlike `xml-query-all', the parsed XML s-expression must
also have its namespace pre-stripped. This is accomplished by
setting the optional PARSE-NS argument of `xml-parse-region' to
symbol-qnames.

Sub-expression lists are not supported by this macro.

QUERY is *not* evaluated, so it should not be quoted."
  (xml-query-all--compile query sexp))

(provide 'xml-query)

;;; xml-query.el ends here