commit 1c67cd0c36348037a0d6866247bb7f0746e9bafe
Author: syn <syn@fca3e652-9b03-0410-8d7b-ac86a6ce46c4>
Date:   Fri Feb 25 22:14:40 2011 +0000

    ssql: port to chicken 4 and remove prometheud dependency
    
    
    git-svn-id: https://code.call-cc.org/svn/chicken-eggs/release/4/ssql/trunk@22895 fca3e652-9b03-0410-8d7b-ac86a6ce46c4

diff --git a/foops.scm b/foops.scm
new file mode 100644
index 0000000..86360bb
--- /dev/null
+++ b/foops.scm
@@ -0,0 +1,56 @@
+(module foops
+
+(make-object derive-object)
+
+(import chicken scheme)
+(use matchable)
+(import-for-syntax chicken)
+(begin-for-syntax
+ (use srfi-1))
+
+(define-for-syntax args-without-self 
+  '(if (and (pair? args) (procedure? (car args)))
+       (cdr args)
+       args))
+
+(define-syntax derive-object
+  (ir-macro-transformer
+   (lambda (x i c)
+     (let-optionals (second x)
+         ((ancestor #f)
+          (self #f)
+          (super #f))
+       
+       `(let ((ancestor ,ancestor))
+          (letrec ((self (lambda args
+                           (if (null? args)
+                               ancestor
+                               (let* ((self* (if (and (pair? args) (procedure? (car args)))
+                                                 (car args)
+                                                 self))
+                                      ,@(if self `((,self self*)) '())
+                                      ,@(if super
+                                            `((,super
+                                               (lambda args
+                                                 (apply ancestor self* args))))
+                                            '())
+                                      (args ,args-without-self))
+                               
+                                 (match args
+                                   ,@(map (lambda (m)
+                                            `(((quote ,(strip-syntax (caar m))) . ,(cdar m))
+                                              . ,(cdr m)))
+                                          (cddr x))
+                                   (_ (apply ancestor self* args))))))))
+            self))))))
+
+(define-syntax make-object
+  (ir-macro-transformer
+   (lambda (x i r)
+     `(derive-object 
+       ((lambda args 
+          (error "message not understood" ,args-without-self))
+        . ,(cadr x))
+       . ,(cddr x)))))
+
+)
\ No newline at end of file
diff --git a/ssql.meta b/ssql.meta
new file mode 100644
index 0000000..9fd9e20
--- /dev/null
+++ b/ssql.meta
@@ -0,0 +1,5 @@
+((synopsis "SQL as S-expressions")
+ (category databases)
+ (needs matchable postgresql)
+ (license "BSD")
+ (author "Peter Bex, Moritz Heidkamp"))
diff --git a/ssql.scm b/ssql.scm
new file mode 100644
index 0000000..0a7e8b4
--- /dev/null
+++ b/ssql.scm
@@ -0,0 +1,235 @@
+(module ssql
+
+(ssql->sql ssql-connection scope-table find-tables 
+ register-sql-engine! define-operators *ansi-translator*)
+
+(import chicken scheme)
+(use matchable data-structures extras srfi-1 srfi-13 foops)
+(import-for-syntax chicken)
+(begin-for-syntax
+ (use srfi-1 srfi-13))
+
+(define-syntax define-operators
+  (ir-macro-transformer
+   (lambda (x i c)
+     (let ((engine (second x)))
+       `(set! ,engine
+              (derive-object (,engine self)
+                             ,@(map (lambda (op)
+                                      (let ((ssql-op (first op))
+                                            (type (second op)))
+                                        (let-optionals (cddr op)
+                                            ((sql-op (string-upcase (->string (strip-syntax ssql-op)))))
+                                          `((,(strip-syntax ssql-op) operands)
+                                            (self 'operator->sql ',type ,sql-op operands)))))
+                                    (cddr x))))))))
+
+(define *ansi-translator*
+  (make-object (self)
+               ((type->sql-converters) 
+                `((,null? . null->sql)
+                  (,pair? . pair->sql)
+                  (,symbol? . source->sql)
+                  (,string? . string->sql)
+                  (,number? . number->sql)))
+
+               ((escape-string string)
+                (string-translate* string '(("'" . "''"))))
+
+               ((null->sql null) "")
+
+               ((pair->sql pair)
+                (self (car pair) (cdr pair)))
+
+               ((string->sql string)
+                (string-append "'" (self 'escape-string string) "'"))
+
+               ((number->sql number)
+                (->string number))
+
+               ((source->sql source)
+                (symbol->string source))
+
+               ((columns ssql)
+                (string-intersperse (map (lambda (s)
+                                           (self 'ssql->sql s))
+                                         ssql)
+                                    ", "))
+
+               ((col ssql)
+                (string-intersperse (map (lambda (colname)
+                                           (self 'ssql->sql (string->symbol (sprintf "~A.~A" (car ssql) colname))))
+                                         (cdr ssql))
+                                    ", "))
+
+               ((join ssql)
+                (match ssql
+                  ((type first rest ...) (sprintf "(~A ~A JOIN ~A)"
+                                                  (self 'ssql->sql first)
+                                                  (string-upcase (symbol->string type))
+                                                  (string-join (map (lambda (x) (self 'ssql->sql x)) rest))))))
+
+               ((operator->sql type operator operands)
+                (case type
+                  ((infix)
+                   (sprintf "(~A)" (string-intersperse
+                                    (map (lambda (operand) 
+                                           (self 'ssql->sql operand))
+                                         operands)
+                                    (string-append " " operator " "))))
+                  ((function)
+                   (sprintf "~A(~A)"
+                            operator
+                            (string-intersperse
+                             (map (lambda (operand) 
+                                    (self 'ssql->sql operand))
+                                  operands)
+                             ", ")))
+                  ((suffix prefix)
+                   (let ((operator (if (eq? type 'prefix)
+                                       (string-append operator " ")
+                                       (string-append " " operator))))
+                     (sprintf "(~A)"
+                              (string-join
+                               (list
+                                (string-intersperse
+                                 (map (lambda (operand)
+                                        (self 'ssql->sql operand))
+                                      operands)))
+                               operator
+                               type))))
+                  (else (error "unknown operator syntax type" type))))
+
+               ((ssql->sql ssql)
+                (let ((handler (alist-ref (list ssql) (self 'type->sql-converters) apply)))
+                  (if handler
+                      (self handler ssql)
+                      (error "unknown datatype" ssql))))))
+
+(define-operators *ansi-translator*
+  (select prefix)
+  (from prefix)
+  (where prefix)
+  (having prefix)
+  (union infix)
+  (as infix)
+  (asc suffix)
+  (desc suffix)
+  (on prefix)
+
+  (and infix)
+  (or infix)
+  (not prefix)
+
+  (min function)
+  (max function)
+  (avg function)
+  (sum function)
+  (count function)
+
+  (distinct prefix)
+  (all prefix)
+
+  (values function)
+
+  (upper function)
+  (lower function)
+  (string-append infix "||")
+  (= infix)
+  (like infix)
+  (escape infix)
+  (< infix)
+  (> infix)
+  (<= infix)
+  (>= infix)
+  (<> infix)
+  (!= infix "<>")
+  (null? suffix "IS NULL"))
+
+(define *sql-engines* `((,(lambda (obj) (eq? obj #f)) . ,*ansi-translator*)))
+
+(define ssql-connection (make-parameter #f))
+
+(define (register-sql-engine! predicate translator)
+  (set! *sql-engines* (alist-cons predicate translator *sql-engines*)))
+
+(define (get-sql-engine connection)
+  (alist-ref (list connection) *sql-engines* apply))
+
+(define (ssql->sql connection ssql)
+  (let ((engine (get-sql-engine connection)))
+    (if engine
+	(parameterize ((ssql-connection connection))
+	 (engine 'ssql->sql ssql))
+	(error (sprintf "No engine found for connection object ~A" connection)))))
+
+(define (escape connection string)
+  ((get-sql-engine connection) 'escape string))
+
+(define (colref? x)
+  (and (symbol? x) (string-any #\. (symbol->string x))))
+
+(define (rewrite-tables ssql renamed)
+  (let loop ((ssql ssql))
+    (match ssql
+      (('col alias cols ...) `(col ,(alist-ref alias renamed eq? alias) ,@cols))
+      (('as table alias) `(as ,table ,(alist-ref alias renamed eq? alias)))
+      ((? colref? col)
+       (let* ((refs (string-split (symbol->string col) "."))
+              (col (string->symbol (car refs))))
+         (string->symbol (string-join (cons
+                                       (symbol->string (alist-ref col renamed eq? col))
+                                       (cdr refs))
+                                      "."))))
+      ((operator operands ...)
+       `(,operator ,@(map (cut loop <>) operands)))
+      (other other))))
+
+(define (scope-table table scope ssql)
+  (let loop ((ssql ssql))
+   (match ssql
+	  ((not (? pair?)) ssql)
+	  ((select ('columns tables ...)
+		   ('from from-specs ...)
+		   ('where conditions ...)
+		   more ...)
+	   (let ((aliases (filter (lambda (x) (eq? (car x) table)) (find-tables (cons 'from from-specs)))))
+	     `(select (columns ,@(map loop tables))
+		      (from ,@(map loop from-specs))
+		      (where (and ,@(map (lambda (alias) (rewrite-tables scope `((,table . ,(cdr alias))))) aliases)
+				  ,(map loop conditions)))
+		      ,@(map loop more))))
+	  ((select ('columns tables ...)
+		   ('from from-specs ...)
+		   more ...)
+	   (=> fail)
+	   (let ((aliases (filter (lambda (x) (eq? (car x) table)) (find-tables (cons 'from from-specs)))))
+	     (if (null? aliases)
+		 (fail) ; Don't inject an empty WHERE
+		 `(select (columns ,@(map loop tables))
+			  (from ,@(map loop from-specs))
+			  (where (and ,@(map (lambda (alias) (rewrite-tables scope `((,table . ,(cdr alias))))) aliases)))
+			  ,@(map loop more)))))
+	  (other (map loop other)))))
+
+;; Find all tables used in a query.  Returns an list of conses: ((table . alias) ...)
+;; A table may occur more than once!
+(define (find-tables ssql)
+  (let loop ((expect-table? #f)
+	     (tables '())
+	     (ssql ssql))
+    (match ssql
+	   ((? symbol?)
+	    (if expect-table?
+		(cons (cons ssql ssql) tables)
+		tables))
+	   (('as (? symbol? table) alias)
+	    (cons (cons table alias) tables))
+	   ((or ('from rest ...)
+		('join _ rest ...))
+	    (append (apply append (map (lambda (tbl) (loop #t '() tbl)) rest)) tables))
+	   ((head tail ...)
+	    (append (loop #f tables head) (loop #f tables tail)))
+	   (_ tables))))
+
+)
\ No newline at end of file
diff --git a/ssql.setup b/ssql.setup
new file mode 100644
index 0000000..441fc9c
--- /dev/null
+++ b/ssql.setup
@@ -0,0 +1,3 @@
+(standard-extension 'foops #f)
+(standard-extension 'ssql #f)
+(standard-extension 'ssql-pgsql #f)
diff --git a/tests/ansi-test.scm b/tests/ansi-test.scm
new file mode 100644
index 0000000..3787877
--- /dev/null
+++ b/tests/ansi-test.scm
@@ -0,0 +1,24 @@
+(use test)
+(import ssql)
+
+(test-begin "selects")
+(test "Simple query"
+  "(SELECT actors.firstname, actors.lastname (FROM actors))"
+  (ssql->sql #f `(select (columns actors.firstname actors.lastname)
+                   (from actors))))
+(test "Many columns"
+  "(SELECT actors.id, actors.firstname, actors.lastname, roles.character, roles.movie_id (FROM actors roles))"
+  (ssql->sql #f `(select (columns (col actors id firstname lastname) (col roles character movie_id))
+                   (from actors roles))))
+(test "Joined query"
+  (string-append
+   "(SELECT actors.firstname, actors.lastname, roles.character, movies.title "
+   "(FROM ((actors LEFT JOIN roles (ON (roles.actor_id = actors.id))) "
+   "LEFT JOIN movies (ON (movies.id = roles.movie_id)))))")
+  (ssql->sql #f `(select (columns actors.firstname actors.lastname roles.character movies.title)
+                   (from (join left
+                               (join left actors roles
+                                     (on (= roles.actor_id actors.id)))
+                               movies
+                               (on (= movies.id roles.movie_id)))))))
+(test-end "selects")
\ No newline at end of file
diff --git a/tests/foops-test.scm b/tests/foops-test.scm
new file mode 100644
index 0000000..8e752e4
--- /dev/null
+++ b/tests/foops-test.scm
@@ -0,0 +1,49 @@
+(load-relative "../foops")
+
+(import foops)
+(use test)
+
+(test-group "basic functionality"
+  (define foo (make-object () ((bar) 'baz)))
+  (test 'baz (foo 'bar))
+
+  (define widget
+    (make-object (self)
+                 ((frob) 'foo)
+                 ((echo s) s)
+                 ((send m) (self m))))
+
+  (test 'foo (widget 'frob))
+  (test "here" (widget 'echo "here"))
+  (test 'foo (widget 'send 'frob))
+  (test-error (widget 'err)))
+
+(test-group "inheritance"
+  (define dinosaur 
+    (make-object (self)
+                 ((sound) 'rawr)
+                 ((talk) (self 'sound))))
+
+  (define t-rex
+    (derive-object (dinosaur self super)
+                   ((sound) 'hah)
+                   ((talk-original) (super 'sound))))
+
+  (test 'rawr (dinosaur 'talk))
+  (test 'hah (t-rex 'talk))
+  (test 'rawr (t-rex 'talk-original)))
+
+
+(test-group "pattern matching"
+  (define vehicle 
+    (make-object (self)
+                 ((drive) 'wroom)
+                 ((drive distance) 
+                  (map (lambda (i) (self 'drive))
+                       (iota distance)))
+                 ((drive distance speed)
+                  (cons speed (self 'drive distance)))))
+
+  (test 'wroom (vehicle 'drive))
+  (test '(wroom wroom) (vehicle 'drive 2))
+  (test '(fast wroom wroom wroom) (vehicle 'drive 3 'fast)))
\ No newline at end of file
diff --git a/tests/pgsql-test.scm b/tests/pgsql-test.scm
new file mode 100644
index 0000000..ed64498
--- /dev/null
+++ b/tests/pgsql-test.scm
@@ -0,0 +1,18 @@
+(load-relative "../ssql-pgsql")
+(import ssql)
+(import ssql-pgsql)
+(use test postgresql foops)
+
+(define *test-pgsql-translator* 
+  (derive-object (*pgsql-translator* self super)
+                 ((escape-string string)
+                  (super (ssql-connection) string))))
+
+(register-sql-engine! (lambda (x) (eq? x #t)) *test-pgsql-translator*)
+
+(test-begin "selects")
+(test "Simple query"
+  "(SELECT actors.firstname, actors.lastname (FROM actors))"
+  (ssql->sql #t `(select (columns actors.firstname actors.lastname)
+                   (from actors))))
+(test-end "selects")
\ No newline at end of file
diff --git a/tests/run.scm b/tests/run.scm
new file mode 100644
index 0000000..699c8af
--- /dev/null
+++ b/tests/run.scm
@@ -0,0 +1,6 @@
+(load-relative "foops-test")
+(load-relative "../ssql")
+(load-relative "transformations-test")
+(load-relative "ansi-test")
+;; (load "mysql-test")
+(load-relative "pgsql-test")
\ No newline at end of file
diff --git a/tests/transformations-test.scm b/tests/transformations-test.scm
new file mode 100644
index 0000000..f3f9f42
--- /dev/null
+++ b/tests/transformations-test.scm
@@ -0,0 +1,42 @@
+(use test)
+(import ssql)
+
+(test-begin "inspection")
+(test "find-tables"
+  `((actors . actors) (roles . roles) (movies . m2) (movies . movies))
+  (find-tables
+   `(select (columns actors.firstname actors.lastname roles.character movies.title)
+      (from (join left
+                  (join left actors
+                        (join inner roles (as movies m2)
+                              (on (and (= m2.id roles.movie_id)
+                                       (> m2.year 2000))))
+                        (on (= roles.actor_id actors.id)))
+                  movies
+                  (on (= movies.id roles.movie_id)))))))
+(test-end "inspection")
+
+(test-begin "scoping")
+(test "scope-table"
+  `(select (columns actors.firstname actors.lastname roles.character movies.title)
+     (from (join left
+                 (join left actors
+                       (join inner roles (as movies m2)
+                             (on (and (= m2.id roles.movie_id)
+                                      (> m2.year 2000))))
+                       (on (= roles.actor_id actors.id)))
+                 movies
+                 (on (= movies.id roles.movie_id))))
+     (where (and (< (col m2 year) 2005)
+                 (< (col movies year) 2005))))
+  (scope-table 'movies `(< (col movies year) 2005)
+               `(select (columns actors.firstname actors.lastname roles.character movies.title)
+                  (from (join left
+                              (join left actors
+                                    (join inner roles (as movies m2)
+                                          (on (and (= m2.id roles.movie_id)
+                                                   (> m2.year 2000))))
+                                    (on (= roles.actor_id actors.id)))
+                              movies
+                              (on (= movies.id roles.movie_id)))))))
+(test-end "scoping")
\ No newline at end of file