commit fcc0be4d35710dc0c49bde833ff23b471e671d09
Author: Tomas Hlavaty <tom@logand.com>
Date: Sun, 31 Jul 2011 05:56:34 +0200
Initial commit
Diffstat:
| A | README | | | 21 | +++++++++++++++++++++ |
| A | cl-2sql.asd | | | 13 | +++++++++++++ |
| A | core.lisp | | | 45 | +++++++++++++++++++++++++++++++++++++++++++++ |
| A | macros.lisp | | | 181 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | packages.lisp | | | 13 | +++++++++++++ |
5 files changed, 273 insertions(+), 0 deletions(-)
diff --git a/README b/README
@@ -0,0 +1,21 @@
+- meta-syntax with keywords (small, fast, not extensible)
+- syntax with macros (M-. etc)
+
+- programmable and evolvable sql syntax
+- embracing many sql dialects
+
+- no custom reader
+ - http://clsql.b9.com/manual/csql-find.html
+ - hu.dwim.rdbms
+- not keyword based
+ - http://marijnhaverbeke.nl/postmodern/s-sql.html
+ - completion, M-.
+- not class based
+ - bloat (rdbms)
+- the above => arbitrary magic
+ - we are defining syntax, right?
+ - make use of lisp then (macros)
+
+- join proper prefix
+
+- minimal core meta-syntax and user macro layer
diff --git a/cl-2sql.asd b/cl-2sql.asd
@@ -0,0 +1,13 @@
+;; -*- lisp; -*-
+
+(asdf:defsystem :cl-2sql
+ :description "cl-2sql -- Lisp to SQL compiler for Common Lisp."
+ :version ""
+ :author "Tomas Hlavaty"
+ :maintainer "Tomas Hlavaty"
+ :licence ""
+ :depends-on (:split-sequence)
+ :serial t
+ :components ((:file "packages")
+ (:file "core")
+ (:file "macros")))
diff --git a/core.lisp b/core.lisp
@@ -0,0 +1,45 @@
+(in-package :2sql)
+
+(defun princ-string (string stream)
+ (write-char #\' stream)
+ (princ string stream) ;; TODO escape
+ (write-char #\' stream))
+
+(defun princ-symbol (x stream)
+ (format stream "~(~{~a_~}~)" ;; TODO .
+ (split-sequence:split-sequence #\. (symbol-name x))))
+
+(defun 2sql (form stream &optional (princ-symbol 'princ-symbol))
+ (let ((lvars nil))
+ (labels ((rec (x)
+ (if (atom x)
+ (etypecase x
+ (string (princ-string x stream))
+ (keyword (princ x stream))
+ (symbol (funcall princ-symbol x stream))
+ (integer (princ x stream)))
+ (ecase (car x)
+ (:lvar
+ (push (cdr x) lvars)
+ (format stream ":~d" (length lvars)))
+ (:par
+ (write-char #\( stream)
+ (rec (cons :lst (cons nil (cdr x))))
+ (write-char #\) stream))
+ (:lst
+ (let ((sep (cadr x))
+ (i 0))
+ (dolist (x (cddr x))
+ (when (plusp i)
+ (princ (or sep " ") stream))
+ (rec x)
+ (incf i))))))))
+ (rec form)
+ lvars)))
+
+(defun 2sql-string (form &optional (princ-symbol 'princ-symbol))
+ (let (lvars)
+ (values
+ (with-output-to-string (s)
+ (setq lvars (2sql (macroexpand form) s princ-symbol)))
+ lvars)))
diff --git a/macros.lisp b/macros.lisp
@@ -0,0 +1,181 @@
+(in-package :2sql-macros)
+
+(cl:defmacro defsyntax (name args &body body)
+ `(cl:progn
+ (cl:export ',name)
+ (cl:defmacro ,name ,args ,@body)))
+
+(defsyntax lst (sep &body body)
+ `(:lst ,sep ,@(cl:mapcar
+ (cl:lambda (x) (cl:if (cl:atom x) x (cl:macroexpand x)))
+ body)))
+
+(defsyntax prefix (name &body args)
+ `(lst nil ,name ,@args))
+
+(defsyntax infix (name &body args)
+ `(lst ,name ,@args))
+
+(defsyntax clause (name &body body)
+ `(lst nil ,name ,@body))
+
+(defsyntax not (exp)
+ `(prefix :not ,exp))
+
+(defsyntax between (what left right)
+ `(lst nil ,what :between ,left :and ,right))
+
+(defsyntax + (&body args)
+ `(infix " + " ,@args))
+
+(defsyntax - (&body args)
+ `(infix " - " ,@args))
+
+(defsyntax = (lexp rexp)
+ `(infix " = " ,lexp ,rexp))
+
+(defsyntax and (&body args)
+ `(infix " AND " ,@args))
+
+(defsyntax or (&body args)
+ `(infix " OR " ,@args))
+
+(defsyntax like (text pattern)
+ `(infix " LIKE " ,text ,pattern))
+
+(defsyntax ilike (text pattern)
+ `(infix " ILIKE " ,text ,pattern))
+
+;; (defsyntax relike (text pattern) ;;regexp like
+;; `(infix " ILIKE " ,text ,pattern))
+
+(defsyntax where (exp)
+ `(clause :where ,exp))
+
+(defsyntax from (&body exp)
+ `(clause :from ,@exp))
+
+(defsyntax cols (cols)
+ `(lst ", " ,@cols))
+
+(defsyntax select (cols &body body)
+ `(clause :select (cols ,cols) ,@body))
+
+(defsyntax delete-from (tab &optional where)
+ `(clause :delete :from ,tab ,@(cl:when where (cl:list where))))
+
+(defsyntax distinct (col)
+ `(lst nil :distinct ,col))
+
+(defsyntax join (kind left right on)
+ `(lst nil ,left ,kind :join ,right :on ,on))
+
+(defsyntax inner-join (left right on)
+ `(join :inner ,left ,right ,on))
+
+(defsyntax natural-join (left right on)
+ `(join :natural ,left ,right ,on))
+
+(defsyntax cross-join (left right on)
+ `(join :cross ,left ,right ,on))
+
+(defsyntax left-join (left right on)
+ `(join :left ,left ,right ,on))
+
+(defsyntax right-join (left right on)
+ `(join :right ,left ,right ,on))
+
+(defsyntax full-join (left right on)
+ `(join (lst nil :full :outer) ,left ,right ,on))
+
+(defsyntax union (&body select-forms)
+ `(lst " UNION " ,@select-forms))
+
+(defsyntax union-all (&body select-forms)
+ `(lst " UNION ALL " ,@select-forms))
+
+(defsyntax intersect (&body select-forms)
+ `(lst " INTERSECT " ,@select-forms))
+
+(defsyntax intersect-all (&body select-forms)
+ `(lst " INTERSECT ALL " ,@select-forms))
+
+(defsyntax except (&body select-forms)
+ `(lst " EXCEPT " ,@select-forms))
+
+(defsyntax except-all (&body select-forms)
+ `(lst " EXCEPT " ,@select-forms))
+
+(defsyntax drop-if-exists (name kind if-exists &body body)
+ `(clause :drop ,kind ,@(cl:when if-exists '(:if :exists)) ,name ,@body))
+
+(defsyntax drop-table (name &optional if-exists cascade)
+ `(drop-if-exists ,name :table ,if-exists ,@(cl:when cascade '(:cascade))))
+
+(defsyntax drop-view (name &optional if-exists)
+ `(drop-if-exists ,name :view ,if-exists))
+
+(defsyntax drop-index (name &optional if-exists)
+ `(drop-if-exists ,name :index ,if-exists))
+
+(defsyntax drop-sequence (name &optional if-exists)
+ `(drop-if-exists ,name :view ,if-exists))
+
+(defsyntax create-index (name unique tab &body cols)
+ `(clause :create ,@(cl:when unique '(:unique)) :index ,name
+ :on ,tab (par ,@cols)))
+
+(defsyntax insert-into (tab cols vals)
+ `(clause :insert :into ,tab (par ,@cols) :values (par ,@vals)))
+
+(defsyntax create-sequence (name &optional temp)
+ `(clause :create ,@(cl:when temp '(:temporary)) :sequence ,name))
+
+(defsyntax curval (seq)
+ `(function :curval ,seq))
+
+(defsyntax nextval (seq)
+ `(function :nextval ,seq))
+
+(defsyntax setval (seq val &optional current)
+ `(function :curval ,seq ,val ,@(cl:unless current '(:false))))
+
+(defsyntax cond (&body cases)
+ `(lst nil :case
+ ,@(cl:loop
+ :for (c b) :in cases
+ :appending (cl:if (cl:eq cl:t c)
+ `(:else ,b)
+ `(:when ,c :then ,b)))
+ :end))
+
+(defsyntax zerop (number)
+ `(= 0 ,number))
+
+(defsyntax par (&body body)
+ `(:par ,@(cl:mapcar
+ (cl:lambda (x) (cl:if (cl:atom x) x (cl:macroexpand x))) body)))
+
+(defsyntax function (name &body args)
+ `(lst nil ,name (par (lst ", " ,@args))))
+
+(defsyntax count (x)
+ `(function :count ,x))
+
+(defsyntax asc (exp)
+ `(prefix :asc ,exp))
+
+(defsyntax desc (exp)
+ `(prefix :desc ,exp))
+
+(defsyntax as (tab alias)
+ `(lst nil ,tab ,alias))
+
+;; order-by group-by having
+;; min max avg sum
+
+(defsyntax lvar (name &optional type)
+ `(:lvar ,name ,@(cl:when type (cl:list type))))
+
+;; (defsyntax type (&body body)
+;; `(:type ,@body))
diff --git a/packages.lisp b/packages.lisp
@@ -0,0 +1,13 @@
+(in-package :cl-user)
+
+(defpackage 2sql
+ (:use :cl)
+ (:export #:2sql #:2sql-string))
+
+(defpackage 2sql-macros
+ (:use)
+ (:nicknames :q) ;; TODO really?
+ (:import-from :cl #:&optional #:&body #:nil))
+
+(defpackage 2sql-tests
+ (:use :cl :2sql))
