Initial commit.

.gitignore

@@ -0,0 +1,8 @@
+*.fasl
+*.dx32fsl
+*.dx64fsl
+*.lx32fsl
+*.lx64fsl
+*.x86f
+*~
+.#*

README.markdown

@@ -0,0 +1,18 @@
+# Sxql
+
+## Usage
+
+## Installation
+
+## Author
+
+* Eitarow Fukamachi (e.arrows@gmail.com)
+
+## Copyright
+
+Copyright (c) 2013 Eitarow Fukamachi (e.arrows@gmail.com)
+
+# License
+
+Licensed under the BSD 2-Clause License.
+

src/clause.lisp

@@ -0,0 +1,71 @@
+(in-package :cl-user)
+(defpackage sxql.clause
+  (:use :cl
+        :sxql.sql-type
+        :sxql.operator))
+(in-package :sxql.clause)
+
+(cl-syntax:use-syntax :annot)
+
+@export
+(defstruct (field-clause (:include sql-clause (name ""))
+                         (:constructor make-field-clause (fields)))
+  (fields nil :type sql-expression))
+
+@export
+(defstruct (from-clause (:include statement-clause (name "FROM"))
+                        (:constructor make-from-clause (statement))))
+
+@export
+(defstruct (where-clause (:include expression-clause (name "WHERE"))
+                         (:constructor make-where-clause (expression))))
+
+@export
+(defstruct (order-by-clause (:include expression-clause (name "ORDER BY"))
+                            (:constructor make-order-by-clause (expression))))
+
+@export
+(defstruct (limit-clause (:include sql-clause (name "LIMIT"))
+                         (:constructor make-limit-clause (count1 &optional count2)))
+  (count1 nil :type sql-variable)
+  (count2 nil :type (or null sql-variable)))
+
+@export
+(defstruct (offset-clause (:include sql-clause (name "OFFSET"))
+                          (:constructor make-offset-clause (offset)))
+  (offset nil :type sql-variable))
+
+@export
+(defstruct (group-by-clause (:include expression-clause (name "GROUP BY"))
+                            (:constructor make-group-by-clause (expression))))
+
+(defun find-make-clause (clause-name &optional (package *package*))
+  (find-constructor clause-name #.(string :-clause)
+                    :package package))
+
+@export
+(defun make-clause (clause-name &rest args)
+  (apply (find-make-clause clause-name #.*package*)
+         (mapcar #'detect-and-convert args)))
+
+(defmethod stringify ((clause field-clause))
+  (if (field-clause-fields clause)
+      (stringify (field-clause-fields clause))
+      (values "*" nil)))
+
+(defmethod stringify ((clause limit-clause))
+  (let ((*use-placeholder* nil))
+    (values
+     (format nil "LIMIT ~A~:[~;~:*, ~A~]"
+             (stringify (limit-clause-count1 clause))
+             (if (limit-clause-count2 clause)
+                 (stringify (limit-clause-count2 clause))
+                 nil))
+     nil)))
+
+(defmethod stringify ((clause offset-clause))
+  (let ((*use-placeholder* nil))
+    (values
+     (format nil "OFFSET ~A"
+             (stringify (offset-clause-offset clause)))
+     nil)))

src/operator.lisp

@@ -0,0 +1,123 @@
+(in-package :cl-user)
+(defpackage sxql.operator
+  (:use :cl
+        :sxql.sql-type))
+(in-package :sxql.operator)
+
+(cl-syntax:use-syntax :annot)
+
+(defmacro define-op ((op-name struct-type &key sql-op-name include-slots) &body body)
+  (check-type op-name symbol)
+  (let ((struct-name (intern (concatenate 'string (symbol-name op-name) #.(string :-op)))))
+    `(defstruct (,struct-name (:include ,struct-type
+                               (name ,(or sql-op-name
+                                          (with-output-to-string (s)
+                                            (loop for c across (symbol-name op-name)
+                                                  if (char= c #\-)
+                                                    do (write-char #\Space s)
+                                                  else
+                                                    do (write-char c s)))))
+                               ,@include-slots)
+                              (:constructor ,(intern (concatenate 'string
+                                                                  #.(string :make-)
+                                                                  (symbol-name op-name)
+                                                                  #.(string :-op)))
+                                  ,(case struct-type
+                                     ((unary-op
+                                       unary-suffix-op) '(var))
+                                     ((infix-op
+                                       infix-list-op) '(left right))
+                                     (conjunctive-op '(&rest expressions)))))
+       ,@body)))
+
+(define-op (:not unary-op))
+(define-op (:is-null unary-op))
+(define-op (:not-null unary-op))
+(define-op (:desc unary-suffix-op))
+(define-op (:asc unary-suffix-op))
+
+(define-op (:= infix-op))
+(define-op (:!= infix-op))
+(define-op (:< infix-op))
+(define-op (:> infix-op))
+(define-op (:<= infix-op))
+(define-op (:>= infix-op))
+(define-op (:as infix-op))
+(define-op (:in infix-list-op))
+(define-op (:not-in infix-list-op))
+(define-op (:like infix-op))
+
+(define-op (:or conjunctive-op))
+(define-op (:and conjunctive-op))
+(define-op (:+ conjunctive-op))
+(define-op (:- conjunctive-op :sql-op-name "-"))
+(define-op (:* conjunctive-op))
+(define-op (:/ conjunctive-op))
+(define-op (:% conjunctive-op))
+
+(defstruct (raw-op (:include sql-op (name ""))
+                   (:constructor make-raw-op (var)))
+  (var nil :type (or string
+                    sql-variable)))
+
+@export
+(defun find-constructor (name suffix &key (package *package*) (errorp t))
+  (check-type name symbol)
+  (let ((func-symbol (intern
+                      (concatenate 'string
+                                   #.(string :make-)
+                                   (symbol-name name)
+                                   suffix)
+                      package)))
+    (if (or errorp (fboundp func-symbol))
+        (symbol-function func-symbol)
+        nil)))
+
+(defun find-make-op (op-name &optional (package *package*))
+  (or (find-constructor op-name #.(string :-op)
+                        :package package
+                        :errorp nil)
+      #'(lambda (&rest expressions)
+          (apply #'make-function-op (symbol-name op-name) expressions))))
+
+@export
+(defun make-op (op-name &rest args)
+  (apply (find-make-op op-name #.*package*)
+         (mapcar #'detect-and-convert args)))
+
+@export
+(defun detect-and-convert (object)
+  (etypecase object
+    (number (make-sql-variable object))
+    (string (make-sql-variable object))
+    (keyword (make-sql-keyword (string-upcase object)))
+    (symbol
+     (if (string= (symbol-name object) "*")
+         (detect-and-convert :*)
+         (make-sql-symbol (string-downcase object))))
+    (list
+     (if (keywordp (car object))
+         (apply #'make-op object)
+         (apply #'make-sql-list
+                (mapcar #'detect-and-convert object))))
+    (structure-object object)))
+
+(defmethod stringify ((op is-null-op))
+  (stringify
+   (make-infix-op "IS"
+                  (is-null-op-var op)
+                  (make-sql-keyword "NULL"))))
+
+(defmethod stringify ((op not-null-op))
+  (stringify
+   (make-infix-op "IS NOT"
+                  (not-null-op-var op)
+                  (make-sql-keyword "NULL"))))
+
+(defmethod stringify ((raw raw-op))
+  (values
+   (format nil "(~A)"
+           (etypecase (raw-op-var raw)
+             (string (raw-op-var raw))
+             (sql-variable (let ((*use-placeholder* nil)) (stringify (raw-op-var raw))))))
+   nil))