commit local changes

extra/db/queries/queries.factor

@@ -3,7 +3,7 @@
 USING: accessors kernel math namespaces sequences random
 strings math.parser math.intervals combinators
 math.bitfields.lib namespaces.lib db db.tuples db.types
-sequences.lib ;
+sequences.lib db.sql classes words shuffle arrays ;
 IN: db.queries
 
 GENERIC: where ( specs obj -- )
@@ -146,7 +146,7 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
         number>string " limit " prepend append
     ] curry change-sql drop ;
 
-: make-advanced-statement ( tuple advanced -- tuple' )
+: make-query ( tuple query -- tuple' )
     dupd
     {
         [ group>> [ do-group ] [ drop ] if* ]
@@ -155,6 +155,43 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
         [ offset>> [ do-offset ] [ drop ] if* ]
     } 2cleave ;
 
-M: db <advanced-select-statement> ( tuple class group order limit offset -- tuple )
-    advanced-statement boa
-    [ <select-by-slots-statement> ] dip make-advanced-statement ;
+M: db <query> ( tuple class group order limit offset -- tuple )
+    \ query boa
+    [ <select-by-slots-statement> ] dip make-query ;
+
+! select ID, NAME, SCORE from EXAM limit 1 offset 3
+
+: select-tuples* ( tuple -- statement )
+    dup
+    [
+        select 0,
+        dup class db-columns [ ", " 0, ]
+        [ dup column-name>> 0, 2, ] interleave
+        from 0,
+        class word-name 0,
+    ] { { } { } { } } nmake
+    >r >r parse-sql 4drop r> r>
+    <simple-statement> maybe-make-retryable do-select ;
+
+M: db <count-statement> ( tuple class groups -- statement )
+    f f f \ query boa
+    [ [ "select count(*) from " 0% 0% where-clause ] query-make ]
+    dip make-query ;
+
+: where-clause* ( tuple specs -- )
+    dupd filter-slots [
+        drop
+    ] [
+        \ where 0,
+        [ 2dup slot-name>> swap get-slot-named where ] map 2array 0,
+        drop
+    ] if-empty ;
+
+: delete-tuple* ( tuple -- sql )
+    dup
+    [
+        delete 0, from 0, dup class db-table 0,
+        dup class db-columns where-clause*
+    ] { { } { } { } } nmake
+    >r >r parse-sql 4drop r> r>
+    <simple-statement> maybe-make-retryable do-select ;

extra/db/sql/sql.factor

@@ -5,7 +5,7 @@ IN: db.sql
 
 SYMBOLS: insert update delete select distinct columns from as
 where group-by having order-by limit offset is-null desc all
-any count avg table values ? ;
+any count avg table values ;
 
 ! Output an s-exp sql statement and an alist of keys/values
 
@@ -25,12 +25,27 @@ DEFER: sql%
 : sql-function, ( seq function -- )
     sql% "(" sql% unclip sql% ")" sql% [ sql% ] each ;
 
+: sql-where ( seq -- )
+B
+    [
+        [ second 0, ]
+        [ first 0, ]
+        [ third 1, \ ? 0, ] tri
+    ] each ;
+
 : sql-array% ( array -- )
+B
     unclip
     {
+        { \ create [ "create table" sql% ] }
+        { \ drop [ "drop table" sql% ] }
+        { \ insert [ "insert into" sql% ] }
+        { \ update [ "update" sql% ] }
+        { \ delete [ "delete" sql% ] }
+        { \ select [ B "select" sql% "," (sql-interleave) ] }
         { \ columns [ "," (sql-interleave) ] }
         { \ from [ "from" "," sql-interleave ] }
-        { \ where [ "where" "and" sql-interleave ] }
+        { \ where [ B "where" 0, sql-where ] }
         { \ group-by [ "group by" "," sql-interleave ] }
         { \ having [ "having" "," sql-interleave ] }
         { \ order-by [ "order by" "," sql-interleave ] }
@@ -51,7 +66,7 @@ DEFER: sql%
 ERROR: no-sql-match ;
 : sql% ( obj -- )
     {
-        { [ dup string? ] [ " " 0% 0% ] }
+        { [ dup string? ] [ 0, ] }
         { [ dup array? ] [ sql-array% ] }
         { [ dup number? ] [ number>string sql% ] }
         { [ dup symbol? ] [ unparse sql% ] }
@@ -61,13 +76,4 @@ ERROR: no-sql-match ;
     } cond ;
 
 : parse-sql ( obj -- sql in-spec out-spec in out )
-    [
-        unclip {
-            { \ create [ "create table" sql% ] }
-            { \ drop [ "drop table" sql% ] }
-            { \ insert [ "insert into" sql% ] }
-            { \ update [ "update" sql% ] }
-            { \ delete [ "delete" sql% ] }
-            { \ select [ "select" sql% ] }
-        } case [ sql% ] each
-    ] { "" { } { } { } { } } nmake ;
+    [ [ sql% ] each ] { { } { } { } } nmake ;

extra/db/tuples/tuples-tests.factor

@@ -227,7 +227,7 @@ TUPLE: exam id name score ;
 
 : random-exam ( -- exam )
         f
-        6 [ CHAR: a CHAR: b [a,b] random ] replicate >string
+        6 [ CHAR: a CHAR: z [a,b] random ] replicate >string
         100 random
     exam boa ;
 
@@ -340,7 +340,9 @@ TUPLE: exam id name score ;
         }
     ] [
         T{ exam } select-tuples
-    ] unit-test ;
+    ] unit-test
+
+    [ 4 ] [ T{ exam } count-tuples ] unit-test ;
 
 TUPLE: bignum-test id m n o ;
 : <bignum-test> ( m n o -- obj )

extra/db/tuples/tuples.factor

@@ -42,8 +42,9 @@ HOOK: <insert-user-assigned-statement> db ( class -- obj )
 HOOK: <update-tuple-statement> db ( class -- obj )
 HOOK: <delete-tuples-statement> db ( tuple class -- obj )
 HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
-TUPLE: advanced-statement group order offset limit ;
-HOOK: <advanced-select-statement> db ( tuple class group order offset limit -- tuple )
+TUPLE: query group order offset limit ;
+HOOK: <query> db ( tuple class group order offset limit -- tuple )
+HOOK: <count-statement> db ( tuple class -- n )
 
 HOOK: insert-tuple* db ( tuple statement -- )
 
@@ -152,9 +153,20 @@ M: retryable execute-statement* ( statement type -- )
     dup dup class <select-by-slots-statement> do-select ;
 
 : select-tuple ( tuple -- tuple/f )
-    dup dup class f f f 1 <advanced-select-statement>
+    dup dup class f f f 1 <query>
     do-select ?first ;
 
-: advanced-select ( tuple groups order offset limit -- tuples )
+: query ( tuple groups order offset limit -- tuples )
     >r >r >r >r dup dup class r> r> r> r>
-    <advanced-select-statement> do-select ;
+    <query> do-select ;
+
+: do-count ( exemplar-tuple statement -- tuples )
+    [
+        [ bind-tuple ] [ nip default-query ] 2bi
+    ] with-disposal ;
+
+: count-tuples ( tuple groups -- n )
+    >r dup dup class r> <count-statement> do-count
+    dup length 1 = [ first first string>number ] [
+        [ first string>number ] map
+    ] if ;