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