commit fcba5552dd91166c445e80be0cc10ba00feebb84
Author: septeql <septeql@telent.net>
Date: Wed, 1 Aug 2007 13:29:50 +0000
new
Diffstat:
5 files changed, 388 insertions(+), 0 deletions(-)
diff --git a/defpackage.lisp b/defpackage.lisp
@@ -0,0 +1,10 @@
+;; -*- Lisp -*-
+(defpackage :septeql
+ (:nicknames "7QL")
+ (:use "CL")
+ (:export #:to-sql))
+
+(in-package :septeql)
+(defvar *tests-file*
+ (merge-pathnames "tests.lisp"
+ (asdf:component-pathname (asdf:find-system :septeql))))
diff --git a/run-tests.lisp b/run-tests.lisp
@@ -0,0 +1,21 @@
+(in-package :septeql)
+
+(defun do-tests (&optional verbose)
+ (with-open-file (stream *tests-file*)
+ (let ((failed nil))
+ (loop
+ (let* ((eof (gensym))
+ (send (read stream nil eof))
+ (expect (read stream nil eof)))
+ (when (eql send eof) (return failed))
+ (let* ((actual (eval send))
+ (summary (list :sent send :expected expect :got actual)))
+ (cond ((equal actual expect)
+ (when verbose
+ (format *trace-output* "OK ~A~% => ~A~%"
+ send expect)))
+ (t
+ (when verbose
+ (format *trace-output* "NOT ~A~% => ~A~% got ~A~%"
+ send expect actual))
+ (push summary failed)))))))))
diff --git a/septeql.asd b/septeql.asd
@@ -0,0 +1,14 @@
+;; -*- Lisp -*-
+(defpackage :septeql-system
+ (:use "CL" "ASDF"))
+
+(in-package :septeql-system)
+
+(defsystem :septeql
+ :version "0"
+ :components ((:file "defpackage")
+ (:file "septeql" :depends-on ("defpackage"))
+ (:file "run-tests" :depends-on ("defpackage"))))
+
+;;; to test, call (do-tests). XXX should write a test-op but I can't
+;;; remember how
diff --git a/septeql.lisp b/septeql.lisp
@@ -0,0 +1,232 @@
+(cl:in-package :septeql)
+
+;;;; literals
+
+(defun lisp-to-sql-string (string)
+ "Does necessary quoting and/or escaping of STRING such that it can be
+interpolated into a SQL statement as a string literal"
+ (with-output-to-string (o)
+ (princ "\'" o)
+ (loop for c across string do
+ (case c
+ ((#\' #\\) (princ c o) (princ c o))
+ (t (princ c o))))
+ (princ "\'" o)))
+
+(defun lisp-to-sql-name (symbol)
+ "Transform the lisp SYMBOL into an identifier that the database will like."
+ (substitute #\_ #\- (symbol-name symbol)))
+
+(defun sql-name-to-lisp (string)
+ "Tranform the database name STRING into a lisp-friendly keyword."
+ (intern (substitute #\- #\_ (string-upcase string)) :keyword))
+
+
+;;;; parsing expressions that return scalar values.
+
+(defparameter *infix-syntax* '(+ - / * = > < >= <= like ilike is and
+ or |::| ~ ~* ! !*)
+ "Functions to be transformed to infix syntax. Must be column-expr * column-expr => column-expr")
+
+(defun infixize (op args)
+ (labels ((i (args)
+ (format nil "(~A ~A ~A)"
+ (if (> (length args) 2)
+ (i (butlast args))
+ (first args))
+ op (car (last args)))))
+ (i args)))
+
+(defvar *scalar-translations* (make-hash-table :test 'equal))
+
+(defun translate-scalar (expr)
+ (typecase expr
+ (string (lisp-to-sql-string expr))
+ (number (format nil "~S" expr))
+ (null "FALSE")
+ (boolean "TRUE")
+ (symbol (lisp-to-sql-name expr))
+ (cons
+ (destructuring-bind (op &rest args) expr
+ (cond
+ ((member op *infix-syntax* :test 'string-equal)
+ (infixize op (mapcar #'translate-scalar args)))
+ (t
+ (let ((func (gethash (symbol-name op) *scalar-translations*)))
+ (if func
+ (apply func args)
+ (format nil "~A(~{~A~^,~})"
+ (lisp-to-sql-name op )
+ (mapcar #'translate-scalar args))))))))))
+
+(defun make-scalar-translator (name lambda)
+ (setf (gethash (symbol-name name) *scalar-translations*) lambda))
+
+(defmacro define-scalar-translator (name args &body forms)
+ `(make-scalar-translator (quote ,name) (lambda ,args ,@forms)))
+
+(define-scalar-translator as (column-expr alias)
+ (format nil "~A AS ~A" (translate-scalar column-expr) (lisp-to-sql-name alias)))
+
+;;; we *could* use the zero-length symbol for string concatenation,
+;;; relying on the printer to render it as ``||'', but that's arguably
+;;; kinda tacky. So, ++ for sticking strings together
+
+(define-scalar-translator ++ (&rest columns)
+ (infixize "||" (mapcar #'translate-scalar columns)))
+
+
+;;;; and relations
+
+
+;;; this models a sql SELECT statement
+;;; XXX we don't support HAVING, mostly becaue I don't understand it
+(defclass sql ()
+ ((attributes :initarg :attributes)
+ (from :initarg :from )
+ (where :initarg :where)
+ (group-by :initarg :group-by)
+ (order-by :initarg :order-by)
+ (start :initarg :start) ; LIMIT and OFFSET are
+ (end :initarg :end) ; computed with these
+ ))
+
+(defmacro sv (ob slot &optional (default nil default-p))
+ (if default-p
+ `(if (slot-boundp ,ob ,slot) (slot-value ,ob ,slot) ,default)
+ `(slot-value ,ob ,slot)))
+
+(defun any-slot-bound-p (ob slots)
+ (some (lambda (s) (slot-boundp ob s)) slots))
+
+(defvar *rel-translations* (make-hash-table :test 'equal))
+
+(defun parse-relation (s)
+ (etypecase s
+ (cons (destructuring-bind (op &rest args) s
+ (apply (gethash (symbol-name op) *rel-translations*) args)))
+ (symbol (make-instance 'sql :from s))))
+
+(defmacro define-translator (op args &body forms)
+ `(setf (gethash (symbol-name ',op) *rel-translations*)
+ (lambda ,args ,@forms)))
+
+(define-translator select (relation predicate)
+ (let ((s (parse-relation relation)))
+ (when (any-slot-bound-p s '(start end group-by))
+ (setf s (make-instance 'sql :from s)))
+ (if (slot-boundp s 'where)
+ (setf (sv s 'where) `(and ,(sv s 'where) ,predicate))
+ (setf (sv s 'where) predicate))
+ s))
+
+(define-translator project (attributes relation)
+ (let ((s (parse-relation relation)))
+ (setf (sv s 'attributes) attributes)
+ s))
+
+(define-translator join (rel1 rel2 expr)
+ (let ((l (parse-relation rel1))
+ (r (parse-relation rel2)))
+ (when (any-slot-bound-p l '(start end group-by attributes order-by where))
+ ;; _any_ slot other than FROM
+ (setf l (make-instance 'sql :from l)))
+ (when (any-slot-bound-p r '(start end group-by attributes order-by where))
+ (setf r (make-instance 'sql :from r)))
+ (make-instance 'sql :from `(join ,(sv l 'from) ,(sv r 'from) ,expr))))
+
+(define-translator group (aggregates dividers relation)
+ (let ((l (parse-relation relation)))
+ (when (any-slot-bound-p l '(start end group-by attributes order-by))
+ (setf l (make-instance 'sql :from l)))
+ (setf (sv l 'attributes)
+ (append aggregates dividers)
+ (sv l 'group-by) dividers)
+ l))
+
+
+(define-translator order (relation attribute &optional direction)
+ (let ((sql (parse-relation relation)))
+ (when (any-slot-bound-p sql '(order-by start end))
+ (setf sql (make-instance 'sql :from sql)))
+ (setf (slot-value sql 'order-by)
+ (cons attribute (or direction :asc)))
+ sql))
+
+(define-translator rename (relation name)
+ (let ((sql (parse-relation relation)))
+ (cond ((any-slot-bound-p sql
+ '(start end group-by attributes order-by where))
+ ;; _any_ slot other than FROM
+ (make-instance 'sql :from `(rename ,sql ,name)))
+ (t
+ (setf (sv sql 'from)
+ `(rename ,(sv sql 'from) ,name))
+ sql))))
+
+
+
+(defun min~ (&rest args)
+ (let ((real-args (remove-if #'not args)))
+ (and (car real-args) (apply #'min real-args))))
+
+(define-translator limit (relation start end)
+ (let ((sql (parse-relation relation)))
+ (let ((start (max start (sv sql 'start 0)))
+ (end (min~ end (sv sql 'end nil))))
+ ;; the effect of nested LIMIT clauses is to use the narrowest ones
+ (setf (sv sql 'start) start
+ (sv sql 'end) end)
+ sql)))
+
+;;; This is a less useful function than its name would suggest.
+;;; It's really only used to give a somewhat sensible name to a
+;;; subselect where the user hasn't provided any
+(defun sql-name (sql)
+ (cond ((typep sql 'sql) (sql-name (sv sql 'from)))
+ ((symbolp sql) sql)
+ ((eql (car sql) 'join) (gensym))
+ ((eql (car sql) 'rename) (third sql))
+ (t (error "no name"))))
+
+(defun from-clause-as-string (from)
+ (cond ((typep from 'sql)
+ (format nil "(~A) ~A " (as-string from) (sql-name from)))
+ ((symbolp from) (lisp-to-sql-name from))
+ ((eql (car from) 'rename)
+ (let ((rel (second from))
+ (name (lisp-to-sql-name (third from))))
+ (if (typep rel 'sql)
+ (format nil "(~A) ~A " (as-string rel) name)
+ (format nil "~A ~A " (from-clause-as-string rel) name))))
+ ((eql (car from) 'join)
+ (format nil "(~A JOIN ~A ON ~A)"
+ (from-clause-as-string (second from))
+ (from-clause-as-string (third from))
+ (translate-scalar (fourth from))))
+ (t (error "buggered if I know"))))
+
+
+(defun as-string (sql)
+ (with-output-to-string (s)
+ (format s "SELECT ~{~A~^,~} "
+ (or (mapcar #'translate-scalar (sv sql 'attributes nil)) '(*)))
+ (format s "FROM ~A " (from-clause-as-string (sv sql 'from)))
+ (let* ((nilg (gensym))
+ (w (sv sql 'where nilg)))
+ (unless (eql w nilg) (format s "WHERE ~A " (translate-scalar w))))
+ (let ((group (sv sql 'group-by nil)))
+ (when group (format s "GROUP BY ~{~A~^,~} "
+ (mapcar #'translate-scalar group))))
+ (let ((order (sv sql 'order-by nil)))
+ (when order (format s "ORDER BY ~A ~A "
+ (translate-scalar (car order))
+ (symbol-name (cdr order)))))
+ (let* ((offset (sv sql 'start 0))
+ (end (sv sql 'end nil)))
+ (unless (zerop offset) (format s "OFFSET ~A " offset))
+ (if end (format s "LIMIT ~A " (- end offset))))))
+
+(defun to-sql (relation)
+ (as-string (parse-relation relation)))
+
diff --git a/tests.lisp b/tests.lisp
@@ -0,0 +1,110 @@
+;;; This file created by kludgy bits of elisp, have a care when
+;;; editing by hand. See http://www.coruskate.net/Testing%20times
+
+;; sent
+(+ 1 2) ; this is a comment
+;; received
+3
+;; sent
+(to-sql '(project ((as (from-universal-time date) ident) name) venue))
+;; received
+"SELECT FROM_UNIVERSAL_TIME(DATE) AS IDENT,NAME FROM VENUE "
+
+;; sent
+(+ 1
+ 2
+ 3)
+
+;; received
+6
+;; sent
+(to-sql 'relation)
+;; received
+"SELECT * FROM RELATION "
+;; sent
+(to-sql '(select relation (= value 1)))
+;; received
+"SELECT * FROM RELATION WHERE (VALUE = 1) "
+;; sent
+(to-sql '(select relation (and (= value 1) (< another 10) (or t nil))))
+;; received
+"SELECT * FROM RELATION WHERE (((VALUE = 1) AND (ANOTHER < 10)) AND (TRUE OR FALSE)) "
+;; sent
+(to-sql '(order relation attribute))
+;; received
+"SELECT * FROM RELATION ORDER BY ATTRIBUTE ASC "
+;; sent
+(to-sql '(order relation attribute :desc))
+;; received
+"SELECT * FROM RELATION ORDER BY ATTRIBUTE DESC "
+;; sent
+(to-sql '(limit (order relation attribute :desc) 5 15))
+;; received
+"SELECT * FROM RELATION ORDER BY ATTRIBUTE DESC OFFSET 5 LIMIT 10 "
+;; sent
+(to-sql '(order (limit relation 5 15) attribute :desc) )
+;; received
+"SELECT * FROM (SELECT * FROM RELATION OFFSET 5 LIMIT 10 ) RELATION ORDER BY ATTRIBUTE DESC "
+;; sent
+(to-sql '(project (att1 att2 att3) relation))
+;; received
+"SELECT ATT1,ATT2,ATT3 FROM RELATION "
+;; sent
+(to-sql '(project (att1 (as att2 name) att3) relation))
+;; received
+"SELECT ATT1,ATT2 AS NAME,ATT3 FROM RELATION "
+;; sent
+(to-sql '(project (att1 (as (function att2 att10) name) att3) relation))
+;; received
+"SELECT ATT1,FUNCTION(ATT2,ATT10) AS NAME,ATT3 FROM RELATION "
+;; sent
+(to-sql '(select r (or (= a b) (> a b) (< a b) (<= a b) (>= a b) (like a b) (ilike a b) (~ a b) (~* a b) (! a b) (!* a b)))) ; all the infix operations
+;; received
+"SELECT * FROM R WHERE (((((((((((A = B) OR (A > B)) OR (A < B)) OR (A <= B)) OR (A >= B)) OR (A LIKE B)) OR (A ILIKE B)) OR (A ~ B)) OR (A ~* B)) OR (A ! B)) OR (A !* B)) "
+;; sent
+(to-sql '(project ((as (++ a b) cat)) r))
+;; received
+"SELECT (A || B) AS CAT FROM R "
+;; sent
+(to-sql '(rename relation new-name))
+;; received
+"SELECT * FROM RELATION NEW_NAME "
+;; sent
+(to-sql '(rename (order relation id) new-name))
+;; received
+"SELECT * FROM (SELECT * FROM RELATION ORDER BY ID ASC ) NEW_NAME "
+;; sent
+(to-sql '(join (join rel1 rel2 predicate) rel3 pred2))
+;; received
+"SELECT * FROM ((REL1 JOIN REL2 ON PREDICATE) JOIN REL3 ON PRED2) "
+;; sent
+(to-sql '(join rel1 rel2 predicate))
+;; received
+"SELECT * FROM (REL1 JOIN REL2 ON PREDICATE) "
+;; sent
+(to-sql '(rename (join rel1 rel2 predicate) newname))
+;; received
+"SELECT * FROM (REL1 JOIN REL2 ON PREDICATE) NEWNAME "
+;; sent
+(to-sql '(rename (order relation attribute) newname))
+;; received
+"SELECT * FROM (SELECT * FROM RELATION ORDER BY ATTRIBUTE ASC ) NEWNAME "
+;; sent
+(to-sql '(select (limit (order relation attribute) 0 3) pred))
+;; received
+"SELECT * FROM (SELECT * FROM RELATION ORDER BY ATTRIBUTE ASC LIMIT 3 ) RELATION WHERE PRED "
+
+;; sent
+(7ql:to-sql '(project ("string") rel))
+;; received
+"SELECT 'string' FROM REL "
+;; sent
+(7ql:to-sql '(project ("str'ing") rel))
+;; received
+"SELECT 'str''ing' FROM REL "
+;; sent
+(7ql:to-sql '(group ((as (sum quantity) quantity) (as (sum (* quantity cost)) value))
+ (event-id event-description)
+ order-line))
+;; received
+"SELECT SUM(QUANTITY) AS QUANTITY,SUM((QUANTITY * COST)) AS VALUE,EVENT_ID,EVENT_DESCRIPTION FROM ORDER_LINE GROUP BY EVENT_ID,EVENT_DESCRIPTION "
+\ No newline at end of file
