branch: elpa/emacsql
commit a164ecd9d31dbd45a646244906ac077d5a331419
Author: Ákos Kiss <a...@coram.pub>
Commit: Ákos Kiss <a...@coram.pub>
Implement operator precedence handling
---
emacsql-compiler.el | 181 ++++++++++++++++++++++++++++------------
tests/emacsql-compiler-tests.el | 17 +++-
2 files changed, 143 insertions(+), 55 deletions(-)
diff --git a/emacsql-compiler.el b/emacsql-compiler.el
index 5e7b9e0577..b1aae9ce63 100644
--- a/emacsql-compiler.el
+++ b/emacsql-compiler.el
@@ -261,7 +261,85 @@ Only use within `emacsql-with-params'!"
(vector (format "(%s)" (mapconcat #'scalar vector ", ")))
(otherwise (emacsql-error "Invalid vector: %S" vector)))))
-(defun emacsql--*expr (expr)
+(defmacro emacsql--generate-op-lookup (operator-name
+ operator-argument-count
+ operator-precedence-groups)
+ `(cond
+ ,@(cl-loop
+ for precedence-value from 1
+ for precedence-group in (reverse operator-precedence-groups)
+ append (cl-loop
+ for (op-name arity sql-format-string) in precedence-group
+ for sql-name = (upcase (symbol-name op-name))
+ for format-string = (or sql-format-string
+ (pcase arity
+ (:unary (cl-concatenate 'string
sql-name " %s"))
+ (:binary (cl-concatenate 'string
+ "%s "
sql-name " %s"))))
+ collect (list `(and (eq ,operator-name (quote ,op-name))
+ ,(if (eq arity :unary)
+ `(eql ,operator-argument-count 1)
+ `(>= ,operator-argument-count 2)))
+ `(list ,format-string ,arity ,precedence-value))))
+ (t (list nil nil nil))))
+
+
+(defun emacsql--get-op (op-name argument-count)
+ (emacsql--generate-op-lookup
+ op-name
+ argument-count
+ (((~ :unary "~%s"))
+ ((collate :binary))
+ ((|| :binary))
+ ((* :binary) (/ :binary) (% :binary))
+ ((+ :unary "+%s") (- :unary "-%s"))
+ ((+ :binary) (- :binary))
+ ((& :binary) (| :binary) (<< :binary) (>> :binary))
+ ((escape :unary "%s ESCAPE"))
+ ((< :binary) (<= :binary) (> :binary) (>= :binary))
+
+ (;;TODO? (between :binary) (not-between :binary)
+ (is :binary) (is-not :binary "%s IS NOT %s")
+ (match :binary) (not-match :binary "%s NOT MATCH %s")
+ (like :binary) (not-like :binary "%s NOT LIKE %s")
+ (in :binary) (not-in :binary "%s NOT IN %s")
+ (isnull :unary "%s ISNULL") (notnull :unary "%s NOTNULL")
+ (= :binary) (== :binary)
+ (!= :binary) (<> :binary)
+ (glob :binary) (not-glob :binary "%s NOT GLOB %s")
+ (regexp :binary) (not-regexp :binary "%s NOT REGEXP %s"))
+
+ ((not :unary))
+ ((and :binary))
+ ((or :binary)))))
+
+(defun emacsql--expand-format-string (op format-string arity argument-count)
+ (when format-string
+ (cond
+ ((and (eq arity :unary) (eql argument-count 1)) format-string)
+ ((and (eq arity :binary) (>= argument-count 2))
+ (cl-loop with acc = format-string
+ for i from 2 below argument-count
+ collect "%s" into rest-args
+ do (setf acc (apply #'format acc format-string rest-args))
+ finally (return acc)))
+ (t (emacsql-error "Wrong number of operands for %s" op)))))
+
+(defun emacsql--get-op-info (op argument-count parent-precedence-value)
+ (cl-destructuring-bind (format-string arity precedence-value)
+ (emacsql--get-op op argument-count)
+ (let ((expanded-format-string (emacsql--expand-format-string op
+ format-string
+ arity
+
argument-count)))
+ (cl-values (cond
+ ((null format-string) nil)
+ ((>= parent-precedence-value
+ precedence-value) (format "(%s)"
expanded-format-string))
+ (t expanded-format-string))
+ precedence-value))))
+
+(defun emacsql--*expr (expr &optional parent-precedence-value)
"Expand EXPR recursively."
(emacsql-with-params ""
(cond
@@ -269,59 +347,54 @@ Only use within `emacsql-with-params'!"
((vectorp expr) (svector expr))
((atom expr) (param expr))
((cl-destructuring-bind (op . args) expr
- (cl-flet ((recur (n) (combine (emacsql--*expr (nth n args))))
- (nops (op)
- (emacsql-error "Wrong number of operands for %s" op)))
- (cl-case op
- ;; Special cases <= >=
- ((<= >=)
- (cl-case (length args)
- (2 (format "%s %s %s" (recur 0) op (recur 1)))
- (3 (format "%s BETWEEN %s AND %s"
- (recur 1)
- (recur (if (eq op '>=) 2 0))
- (recur (if (eq op '>=) 0 2))))
- (otherwise (nops op))))
- ;; Special case -
- ((-)
- (cl-case (length args)
- (1 (format "-(%s)" (recur 0)))
- (2 (format "%s - %s" (recur 0) (recur 1)))
- (otherwise (nops op))))
- ;; Unary
- ((not)
- (format "NOT %s" (recur 0)))
- ((notnull)
- (format "%s NOTNULL" (recur 0)))
- ((isnull)
- (format "%s ISNULL" (recur 0)))
- ;; Ordering
- ((asc desc)
- (format "%s %s" (recur 0) (upcase (symbol-name op))))
- ;; Special case quote
- ((quote) (let ((arg (nth 0 args)))
- (if (stringp arg)
- (raw arg)
- (scalar arg))))
- ;; Special case funcall
- ((funcall)
- (format "%s(%s)" (recur 0)
- (cond
- ((and (= 2 (length args))
- (eq '* (nth 1 args)))
- "*")
- ((and (= 3 (length args))
- (eq :distinct (nth 1 args))
- (format "DISTINCT %s" (recur 2))))
- ((mapconcat
- #'recur (cl-loop for i from 1 below (length args)
- collect i)
- ", ")))))
- ;; Guess
- (otherwise
- (mapconcat
- #'recur (cl-loop for i from 0 below (length args) collect i)
- (format " %s " (upcase (symbol-name op))))))))))))
+ (cl-multiple-value-bind (format-string precedence-value)
+ (emacsql--get-op-info op
+ (length args)
+ (or parent-precedence-value 0))
+ (cl-flet ((recur (n) (combine (emacsql--*expr (nth n args)
+ (or precedence-value
0))))
+ (nops (op)
+ (emacsql-error "Wrong number of operands for %s"
op)))
+ (cl-case op
+ ;; Special cases <= >=
+ ((<= >=)
+ (cl-case (length args)
+ (2 (format format-string (recur 0) (recur 1)))
+ (3 (format "%s BETWEEN %s AND %s"
+ (recur 1)
+ (recur (if (eq op '>=) 2 0))
+ (recur (if (eq op '>=) 0 2))))
+ (otherwise (nops op))))
+ ;; Ordering
+ ((asc desc)
+ (format "%s %s" (recur 0) (upcase (symbol-name op))))
+ ;; Special case quote
+ ((quote) (let ((arg (nth 0 args)))
+ (if (stringp arg)
+ (raw arg)
+ (scalar arg))))
+ ;; Special case funcall
+ ((funcall)
+ (format "%s(%s)" (recur 0)
+ (cond
+ ((and (= 2 (length args))
+ (eq '* (nth 1 args)))
+ "*")
+ ((and (= 3 (length args))
+ (eq :distinct (nth 1 args))
+ (format "DISTINCT %s" (recur 2))))
+ ((mapconcat
+ #'recur (cl-loop for i from 1 below (length args)
+ collect i)
+ ", ")))))
+ ;; Guess
+ (otherwise
+ (let ((arg-indices (cl-loop for i from 0 below (length args)
collect i)))
+ (if format-string
+ (apply #'format format-string (mapcar #'recur
arg-indices))
+ (mapconcat
+ #'recur (cl-loop for i from 0 below (length args) collect
i)
+ (format " %s " (upcase (symbol-name op)))))))))))))))
(defun emacsql--*idents (idents)
"Read in a vector of IDENTS identifiers, or just an single identifier."
diff --git a/tests/emacsql-compiler-tests.el b/tests/emacsql-compiler-tests.el
index cb92ee04d6..79ec6b41e6 100644
--- a/tests/emacsql-compiler-tests.el
+++ b/tests/emacsql-compiler-tests.el
@@ -159,7 +159,7 @@
([:order-by [$i1]] '(bar)
"ORDER BY bar;")
([:order-by (- foo)] '()
- "ORDER BY -(foo);")
+ "ORDER BY -foo;")
([:order-by [(asc a) (desc (/ b 2))]] '()
"ORDER BY a ASC, b / 2 DESC;")))
@@ -192,6 +192,8 @@
([:where (and $i1 $i2 $i3)] '(a b c)
"WHERE a AND b AND c;")
([:where (is foo (not nil))] '()
+ "WHERE foo IS (NOT NULL);")
+ ([:where (is-not foo nil)] '()
"WHERE foo IS NOT NULL;")
([:where (= attrib :name)] '()
"WHERE attrib = ':name';")))
@@ -229,6 +231,19 @@
([:select (funcall count :distinct x)] '()
"SELECT count(DISTINCT x);")))
+(ert-deftest emacsql-precedence ()
+ (emacsql-tests-with-queries
+ ([:select (<< (not (is x nil)) 4)] '()
+ "SELECT (NOT x IS NULL) << 4;")
+ ([:select (* 3 (+ (/ 14 2) (- 5 3)))] '()
+ "SELECT 3 * (14 / 2 + (5 - 3));")
+ ([:select (- (|| (~ x) y))] '()
+ "SELECT -~x || y;")
+ ([:select (funcall length (|| (* x x) (* y y) (* z z)))] '()
+ "SELECT length((x * x) || (y * y) || (z * z));")
+ ([:select (and (+ (<= x y) 1) (>= y x))] '()
+ "SELECT (x <= y) + 1 AND y >= x;")))
+
(provide 'emacsql-compiler-tests)
;;; emacsql-tests.el ends here
