allow inserts without explicit column list
[chicken-eggs:ssql.git] / ssql.scm
1 (module ssql
2
3 (ssql->sql ssql-connection scope-table find-tables ssql-compose
4  register-sql-engine! define-operators *ansi-translator*)
5
6 (import chicken scheme)
7 (use matchable data-structures extras srfi-1 srfi-13 foops)
8 (import-for-syntax chicken)
9 (begin-for-syntax
10  (use srfi-1 srfi-13))
11
12 (define (before? x y lst)
13   (let loop ((lst lst))
14     (or (null? lst)
15         (eq? x (car lst))
16         (and (not (eq? y (car lst)))
17              (loop (cdr lst))))))
18
19 (define-syntax define-operators
20   (ir-macro-transformer
21    (lambda (x i c)
22      (let ((engine (second x)))
23        `(set! ,engine
24               (derive-object (,engine self)
25                              ,@(map (lambda (op)
26                                       (let ((ssql-op (first op))
27                                             (type (second op)))
28
29                                         (unless (memq (i type) '(infix infix* suffix prefix function))
30                                           (error "unknown operator syntax type" type))
31
32                                         (let-optionals (cddr op)
33                                             ((sql-op (string-upcase (->string (strip-syntax ssql-op))))
34                                              (separator #f))
35                                           `((,(i ssql-op) operands)
36                                             (self 'operator->sql ',type ,sql-op ,separator operands)))))
37                                     (cddr x))))))))
38
39 (define *ansi-translator*
40   (make-object (self)
41                ((type->sql-converters) 
42                 `((,null? . null->sql)
43                   (,pair? . pair->sql)
44                   (,symbol? . source->sql)
45                   (,string? . string->sql)
46                   (,number? . number->sql)
47                   (,vector? . vector->sql)))
48
49                ((clauses-order) '(columns from where order having union))
50
51                ((escape-string string)
52                 (string-translate* string '(("'" . "''"))))
53
54                ((null->sql null) "")
55
56                ((pair->sql pair)
57                 (self (car pair) (cdr pair)))
58                
59                ((values vals)
60                 (sprintf "(~A)"
61                          (string-intersperse
62                           (map (lambda (s)
63                                  (self 'ssql->sql s #t))
64                                vals)
65                           ", ")))
66
67                ((vector->sql vec)
68                 (self 'values (vector->list vec)))
69
70                ((string->sql string)
71                 (string-append "'" (self 'escape-string string) "'"))
72
73                ((number->sql number)
74                 (->string number))
75
76                ((source->sql source)
77                 (symbol->string source))
78
79                ((columns ssql)
80                 (string-intersperse (map (lambda (s)
81                                            (self 'ssql->sql s))
82                                          ssql)
83                                     ", "))
84
85                ((col ssql)
86                 (string-intersperse (map (lambda (colname)
87                                            (self 'ssql->sql 
88                                                  (string->symbol (sprintf "~A.~A" 
89                                                                           (car ssql)
90                                                                           (self 'ssql->sql colname)))))
91                                          (cdr ssql))
92                                     ", "))
93
94                ((join ssql)
95                 (match ssql
96                   ((type first rest ...) (sprintf "(~A ~A JOIN ~A)"
97                                                   (self 'ssql->sql first)
98                                                   (string-upcase (symbol->string type))
99                                                   (string-join (map (lambda (x) (self 'ssql->sql x)) rest))))))
100
101                ((set values)
102                 (string-append "SET "
103                                (string-intersperse (map (lambda (val)
104                                                           (sprintf "~A = ~A" 
105                                                                    (first val)
106                                                                    (self 'ssql->sql (second val))))
107                                                         values)
108                                                    ", ")))
109
110                ((insert into values)
111                 (sprintf "INSERT INTO ~A VALUES ~A"
112                          into
113                          (string-intersperse (map (lambda (val) 
114                                                     (self (car val) (cdr val)))
115                                                   values) ", ")))
116
117                ((insert (('into table) ('columns columns ...) values ...))
118                 (self 'insert
119                       (sprintf "~A (~A)" 
120                                table
121                                (string-intersperse (map symbol->string columns) ", "))
122                       values))
123
124                ((insert (('into table) values ...))
125                 (self 'insert table values))
126
127                ((operator->sql type operator separator operands)
128                 (case type
129                   ((infix)
130                    (sprintf "(~A)" (self 'operator->sql 'infix* operator separator operands)))
131
132                   ((infix*)
133                    (string-intersperse
134                     (map (lambda (operand) 
135                            (self 'ssql->sql operand))
136                          operands)
137                     (string-append " " operator " ")))
138
139                   ((function)
140                    (sprintf "~A(~A)"
141                             operator
142                             (string-intersperse
143                              (map (lambda (operand) 
144                                     (self 'ssql->sql operand))
145                                   operands)
146                              (or separator ", "))))
147                   ((suffix prefix)
148                    (let ((operator (if (eq? type 'prefix)
149                                        (string-append operator " ")
150                                        (string-append " " operator))))
151                      (string-join
152                       (list
153                        (string-intersperse
154                         (map (lambda (operand)
155                                (self 'ssql->sql operand))
156                              operands)
157                         (or separator " ")))
158                       operator
159                       type)))
160                   (else (error "unknown operator syntax type" type))))
161
162                ((ssql->sql ssql parenthesize?)
163                 (let ((handler (alist-ref (list ssql) (self 'type->sql-converters) apply)))
164                   (if handler
165                       (if (and parenthesize? (pair? ssql))
166                           (sprintf "(~A)" (self handler ssql))
167                           (self handler ssql))
168                       (error "unknown datatype" ssql))))
169
170                ((ssql->sql ssql)
171                 (self 'ssql->sql ssql #f))
172
173                ((insert-clause clause ssql)
174                 (let ((order (self 'clauses-order)))
175                   (let loop ((ssql ssql))
176                     (cond ((null? ssql) (list clause))
177                           ((before? (car clause) (caar ssql) order)
178                            (cons clause ssql))
179                           (else (cons (car ssql) (loop (cdr ssql))))))))
180
181                ((merge-clauses target-clause clause)
182                 (append target-clause (cdr clause)))))
183
184 (define-operators *ansi-translator*
185   (select prefix)
186   (update prefix)
187   (from prefix "FROM" ", ")
188   (where prefix)
189   (order prefix "ORDER BY" ", ")
190   (having prefix)
191   (union infix)
192   (as infix*)
193   (asc suffix)
194   (desc suffix)
195   (on prefix)
196
197   (and infix)
198   (or infix)
199   (not prefix)
200
201   (min function)
202   (max function)
203   (avg function)
204   (sum function)
205   (count function)
206
207   (distinct prefix)
208   (all prefix)
209
210   (upper function)
211   (lower function)
212   (string-append infix "||")
213   (= infix)
214   (like infix)
215   (in infix)
216   (escape infix)
217   (< infix)
218   (> infix)
219   (<= infix)
220   (>= infix)
221   (<> infix)
222   (!= infix "<>")
223   (null? suffix "IS NULL"))
224
225 (define *sql-engines* `((,(lambda (obj) (eq? obj #f)) . ,*ansi-translator*)))
226
227 (define ssql-connection (make-parameter #f))
228
229 (define (register-sql-engine! predicate translator)
230   (set! *sql-engines* (alist-cons predicate translator *sql-engines*)))
231
232 (define (get-sql-engine connection)
233   (alist-ref (list connection) *sql-engines* apply))
234
235 (define (call-with-sql-engine connection proc)
236   (let ((engine (get-sql-engine connection)))
237     (if engine
238         (parameterize ((ssql-connection connection))
239           (proc engine))
240         (error (sprintf "No engine found for connection object ~A" connection)))))
241
242 (define (ssql->sql connection ssql)
243   (call-with-sql-engine connection
244     (lambda (engine)
245       (engine 'ssql->sql ssql))))
246
247 (define (escape connection string)
248   ((get-sql-engine connection) 'escape string))
249
250 (define (colref? x)
251   (and (symbol? x) (string-any #\. (symbol->string x))))
252
253 (define (rewrite-tables ssql renamed)
254   (let loop ((ssql ssql))
255     (match ssql
256       (('col alias cols ...) `(col ,(alist-ref alias renamed eq? alias) ,@cols))
257       (('as table alias) `(as ,table ,(alist-ref alias renamed eq? alias)))
258       ((? colref? col)
259        (let* ((refs (string-split (symbol->string col) "."))
260               (col (string->symbol (car refs))))
261          (string->symbol (string-join (cons
262                                        (symbol->string (alist-ref col renamed eq? col))
263                                        (cdr refs))
264                                       "."))))
265       ((operator operands ...)
266        `(,operator ,@(map (cut loop <>) operands)))
267       (other other))))
268
269 (define (scope-table table scope ssql)
270   (let loop ((ssql ssql))
271    (match ssql
272           ((not (? pair?)) ssql)
273           ((select ('columns tables ...)
274                    ('from from-specs ...)
275                    ('where conditions ...)
276                    more ...)
277            (let ((aliases (filter (lambda (x) (eq? (car x) table)) (find-tables (cons 'from from-specs)))))
278              `(select (columns ,@(map loop tables))
279                       (from ,@(map loop from-specs))
280                       (where (and ,@(map (lambda (alias) (rewrite-tables scope `((,table . ,(cdr alias))))) aliases)
281                                   ,(map loop conditions)))
282                       ,@(map loop more))))
283           ((select ('columns tables ...)
284                    ('from from-specs ...)
285                    more ...)
286            (=> fail)
287            (let ((aliases (filter (lambda (x) (eq? (car x) table)) (find-tables (cons 'from from-specs)))))
288              (if (null? aliases)
289                  (fail) ; Don't inject an empty WHERE
290                  `(select (columns ,@(map loop tables))
291                           (from ,@(map loop from-specs))
292                           (where (and ,@(map (lambda (alias) (rewrite-tables scope `((,table . ,(cdr alias))))) aliases)))
293                           ,@(map loop more)))))
294           (other (map loop other)))))
295
296 ;; Find all tables used in a query.  Returns an list of conses: ((table . alias) ...)
297 ;; A table may occur more than once!
298 (define (find-tables ssql)
299   (let loop ((expect-table? #f)
300              (tables '())
301              (ssql ssql))
302     (match ssql
303            ((? symbol?)
304             (if expect-table?
305                 (cons (cons ssql ssql) tables)
306                 tables))
307            (('as (? symbol? table) alias)
308             (cons (cons table alias) tables))
309            ((or ('from rest ...)
310                 ('join _ rest ...))
311             (append (apply append (map (lambda (tbl) (loop #t '() tbl)) rest)) tables))
312            ((head tail ...)
313             (append (loop #f tables head) (loop #f tables tail)))
314            (_ tables))))
315
316 (define (ssql-compose connection ssql clauses)
317   (call-with-sql-engine connection
318     (lambda (engine)
319       (cons (car ssql)
320             (fold-right (lambda (clause ssql)
321                           (let ((target-clause (alist-ref (car clause) ssql)))
322                             (if target-clause
323                                 (alist-update! (car clause)
324                                                (engine 'merge-clauses target-clause clause)
325                                                ssql)
326                                 (engine 'insert-clause clause ssql))))
327                         (cdr ssql)
328                         clauses)))))
329
330
331 )