From eaf45653a5c018ec1765b29793e31ec59906bb19 Mon Sep 17 00:00:00 2001
From: Moritz Heidkamp <moritz.heidkamp@bevuta.com>
Date: Fri, 26 Aug 2011 16:21:58 +0200
Subject: [PATCH] add array literal support, as well as the @> and <@ operators

---
 ssql-postgresql.scm | 18 ++++++++++++++----
 tests/run.scm       | 20 +++++++++++++++++---
 2 files changed, 31 insertions(+), 7 deletions(-)

diff --git a/ssql-postgresql.scm b/ssql-postgresql.scm
index 5dcf3c5..920b196 100644
--- a/ssql-postgresql.scm
+++ b/ssql-postgresql.scm
@@ -3,7 +3,7 @@
 (*postgresql-translator*)
 
 (import chicken scheme)
-(use ssql postgresql foops)
+(use ssql postgresql foops data-structures)
 
 (define *postgresql-translator* 
   (let ((type->sql-converters 
@@ -12,7 +12,7 @@
         (clauses-order (append (*ansi-translator* 'clauses-order)
                                '(returning))))
 
-    (derive-object (*ansi-translator*)
+    (derive-object (*ansi-translator* self)
                    ((escape-string string)
                     (escape-string (ssql-connection) string))
 
@@ -21,13 +21,23 @@
 
                    ((clauses-order) clauses-order)
 
-                   ((type->sql-converters) type->sql-converters))))
+                   ((type->sql-converters) type->sql-converters)
+
+                   ((array (elements ...))
+                    (sprintf "ARRAY[~A]"
+                             (string-intersperse 
+                              (map (lambda (el)
+                                     (self 'ssql->sql el))
+                                   elements)
+                              ", "))))))
 
 (define-operators *postgresql-translator*
   (limit prefix)
   (offset prefix)
   (returning prefix "RETURNING" ", ")
-  (random function))
+  (random function)
+  (@> infix)
+  (<@ infix))
 
 (register-sql-engine! connection? *postgresql-translator*)
 
diff --git a/tests/run.scm b/tests/run.scm
index 85169ec..d2db4d4 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -27,10 +27,24 @@
 
   (test "returning"
     "INSERT INTO widgets VALUES ('foo', 'bar') RETURNING id, name"
-    (ssql->sql #t '(insert (into widgets) (values ("foo" "bar")) (returning id name))))
+    (ssql->sql #t '(insert (into widgets) (values #("foo" "bar")) (returning id name))))
 
   (test "compose returning"
-    '(insert (into widgets) (values (1 2 3)) (returning id))
-    (ssql-compose #t '(insert (into widgets) (values (1 2 3))) '((returning id)))))
+    '(insert (into widgets) (values #(1 2 3)) (returning id))
+    (ssql-compose #t '(insert (into widgets) (values #(1 2 3))) '((returning id)))))
+
+
+(test-group "arrays"
+  (test "literals"
+    "SELECT ARRAY[1, 2, 3]"
+    (ssql->sql #t '(select (array 1 2 3))))
+
+  (test "contains operator"
+    "SELECT (ARRAY['foo', 'bar'] @> ARRAY['bar'])"
+    (ssql->sql #t '(select (@> (array "foo" "bar") (array "bar")))))
+  
+  (test "is contained operator"
+    "SELECT (ARRAY['bar'] <@ ARRAY['foo', 'bar'])"
+    (ssql->sql #t '(select (<@ (array "bar") (array "foo" "bar"))))))
 
 (test-exit)
\ No newline at end of file