From 7c27be9b96ab933046cb5cd6ac39dfe4fb23bcf0 Mon Sep 17 00:00:00 2001
From: Moritz Heidkamp <moritz-gitorious@twoticketsplease.de>
Date: Sun, 6 Mar 2011 14:41:43 +0100
Subject: [PATCH] very basic ssql composition support through the
 `ssql-compose' procedure

---
 ssql.scm                   | 41 +++++++++++++++++++++++++++++++++++---
 tests/composition-test.scm | 13 ++++++++++++
 tests/run.scm              |  1 +
 3 files changed, 52 insertions(+), 3 deletions(-)
 create mode 100644 tests/composition-test.scm

diff --git a/ssql.scm b/ssql.scm
index 86c0fa2..06cc717 100644
--- a/ssql.scm
+++ b/ssql.scm
@@ -1,6 +1,6 @@
 (module ssql
 
-(ssql->sql ssql-connection scope-table find-tables 
+(ssql->sql ssql-connection scope-table find-tables ssql-compose
  register-sql-engine! define-operators *ansi-translator*)
 
 (import chicken scheme)
@@ -38,6 +38,8 @@
                   (,string? . string->sql)
                   (,number? . number->sql)))
 
+               ((clauses-order) '(columns from where order having union))
+
                ((escape-string string)
                 (string-translate* string '(("'" . "''"))))
 
@@ -162,13 +164,18 @@
 (define (get-sql-engine connection)
   (alist-ref (list connection) *sql-engines* apply))
 
-(define (ssql->sql connection ssql)
+(define (call-with-sql-engine connection proc)
   (let ((engine (get-sql-engine connection)))
     (if engine
 	(parameterize ((ssql-connection connection))
-	 (engine 'ssql->sql ssql))
+          (proc engine))
 	(error (sprintf "No engine found for connection object ~A" connection)))))
 
+(define (ssql->sql connection ssql)
+  (call-with-sql-engine connection
+    (lambda (engine)
+      (engine 'ssql->sql ssql))))
+
 (define (escape connection string)
   ((get-sql-engine connection) 'escape string))
 
@@ -238,4 +245,32 @@
 	    (append (loop #f tables head) (loop #f tables tail)))
 	   (_ tables))))
 
+(define (before? x y lst)
+  (let loop ((lst lst))
+    (or (null? lst)
+        (eq? x (car lst))
+        (and (not (eq? y (car lst)))
+             (loop (cdr lst))))))
+
+(define (insert-clause engine clause ssql)
+  (let ((order (engine 'clauses-order)))
+    (let loop ((ssql ssql))
+      (cond ((null? ssql) (list clause))
+            ((before? (car clause) (caar ssql) order)
+             (cons clause ssql))
+            (else (cons (car ssql) (loop (cdr ssql))))))))
+
+(define (ssql-compose connection ssql clauses)
+  (call-with-sql-engine connection
+    (lambda (engine)
+      (cons (car ssql)
+            (fold-right (lambda (clause ssql)
+                          (let ((target (alist-ref (car clause) ssql)))
+                            (if target
+                                (alist-update! (car clause) (append target (cdr clause)) ssql)
+                                (insert-clause engine clause ssql))))
+                        (cdr ssql)
+                        clauses)))))
+
+
 )
\ No newline at end of file
diff --git a/tests/composition-test.scm b/tests/composition-test.scm
new file mode 100644
index 0000000..b0e3bab
--- /dev/null
+++ b/tests/composition-test.scm
@@ -0,0 +1,13 @@
+(use test)
+(import ssql)
+
+(test "simple"
+  '(select (columns firstname lastname) (from artists) (where (= firstname "Frank")))
+  (ssql-compose #f
+                '(select (columns firstname lastname) (from artists))
+                '((where (= firstname "Frank")))))
+
+(test "merge"
+  '(select (columns firstname lastname age) (from artists) (order firstname lastname))
+  (ssql-compose #f '(select (columns firstname lastname) (order firstname))
+                '((columns age) (from artists) (order lastname))))
\ No newline at end of file
diff --git a/tests/run.scm b/tests/run.scm
index a1cdafa..755b1e2 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -2,5 +2,6 @@
 (load-relative "../ssql")
 (load-relative "transformations-test")
 (load-relative "ansi-test")
+(load-relative "composition-test")
 
 (test-exit)
\ No newline at end of file