very basic ssql composition support through the `ssql-compose' procedure

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

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

tests/run.scm

@@ -2,5 +2,6 @@
 (load-relative "../ssql")
 (load-relative "transformations-test")
 (load-relative "ansi-test")
+(load-relative "composition-test")
 
 (test-exit)