new

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))))

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)))))))))

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

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)))
+

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 "