interval, range queries in sqlite

extra/db/sqlite/sqlite.factor

@@ -5,7 +5,7 @@ hashtables io.files kernel math math.parser namespaces
 prettyprint sequences strings classes.tuple alien.c-types
 continuations db.sqlite.lib db.sqlite.ffi db.tuples
 words combinators.lib db.types combinators math.intervals
-io namespaces.lib accessors ;
+io namespaces.lib accessors vectors math.ranges ;
 USE: tools.walker
 IN: db.sqlite
 
@@ -104,7 +104,8 @@ M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
 
 : sqlite-make ( class quot -- )
     >r sql-props r>
-    { "" { } { } } nmake <simple-statement> ; inline
+    [ 0 sql-counter rot with-variable ] { "" { } { } } nmake
+    <simple-statement> ; inline
 
 M: sqlite-db create-sql-statement ( class -- statement )
     [
@@ -134,6 +135,12 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
 M: sqlite-db <insert-nonnative-statement> ( tuple -- statement )
     <insert-native-statement> ;
 
+M: sqlite-db bind# ( spec obj -- )
+    >r
+    [ column-name>> ":" swap next-sql-counter 3append dup 0% ]
+    [ type>> ] bi
+    r> <literal-bind> 1, ;
+
 M: sqlite-db bind% ( spec -- )
     dup 1, column-name>> ":" prepend 0% ;
 
@@ -141,38 +148,44 @@ M: sqlite-db bind% ( spec -- )
     " where " 0%
     find-primary-key dup column-name>> 0% " = " 0% bind% ;
 
-! : where-object ( tuple specs -- )
-    ! [ dup column-name>> get-slot-named ] keep
-    ! dup column-name>> 0% " = " 0% bind% ;
-
-GENERIC: where-object ( specs obj -- )
+GENERIC: where ( specs obj -- )
 
 : interval-comparison ( ? str -- str )
     "from" = " >" " <" ? swap [ "= " append ] when ;
 
-: where-interval ( spec val ? from/to -- )
-    roll [
-        column-name>>
-        [ 0% interval-comparison 0% ]
-        [ ":" spin 3append dup 0% ] 2bi
-        swap
-    ] [
-        type>>
-    ] bi literal-bind boa 1, ;
+: where-interval ( spec obj from/to -- )
+    pick column-name>> 0%
+    >r first2 r> interval-comparison 0%
+    bind# ;
 
-M: interval where-object ( specs obj -- )
-    [ from>> first2 "from" where-interval " and " 0% ]
-    [ to>> first2 "to" where-interval ] 2bi ;
+: in-parens ( quot -- )
+    "(" 0% call ")" 0% ; inline
 
-M: object where-object ( specs obj -- )
-    drop
-    dup column-name>> 0% " = " 0% bind% ;
+M: interval where ( spec obj -- )
+    [
+        [ from>> "from" where-interval " and " 0% ]
+        [ to>> "to" where-interval ] 2bi
+    ] in-parens ;
+
+M: sequence where ( spec obj -- )
+    [
+        [ " or " 0% ] [ dupd where ] interleave drop
+    ] in-parens ;
+
+: object-where ( spec obj -- )
+    over column-name>> 0% " = " 0% bind# ;
+
+M: object where ( spec obj -- ) object-where ;
+
+M: integer where ( spec obj -- ) object-where ;
+
+M: string where ( spec obj -- ) object-where ;
 
 : where-clause ( tuple specs -- )
     " where " 0% [
         " and " 0%
     ] [
-        2dup slot-name>> swap get-slot-named where-object
+        2dup slot-name>> swap get-slot-named where
     ] interleave drop ;
 
 M: sqlite-db <update-tuple-statement> ( class -- statement )
@@ -193,9 +206,6 @@ M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
         dup column-name>> 0% " = " 0% bind%
     ] sqlite-make ;
 
-! : select-interval ( interval name -- ) ;
-! : select-sequence ( seq name -- ) ;
-
 M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
     [
         "select " 0%

extra/db/tuples/tuples-tests.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io.files kernel tools.test db db.tuples
-db.types continuations namespaces math
+db.types continuations namespaces math math.ranges
 prettyprint tools.walker db.sqlite calendar
 math.intervals db.postgresql ;
 IN: db.tuples.tests
@@ -217,7 +217,7 @@ TUPLE: serialize-me id data ;
 
 TUPLE: exam id name score ; 
 
-: test-ranges ( -- )
+: test-intervals ( -- )
     exam "EXAM"
     {
         { "id" "ID" +native-id+ }
@@ -267,9 +267,31 @@ TUPLE: exam id name score ;
         }
     ] [
         T{ exam f T{ interval f { 3 t } { 4 t } } f } select-tuples
+    ] unit-test
+
+    [
+        {
+            T{ exam f 1 "Kyle" 100 }
+            T{ exam f 2 "Stan" 80 }
+        }
+    ] [
+        T{ exam f f { "Stan" "Kyle" } } select-tuples
+    ] unit-test
+
+    [
+        {
+            T{ exam f 1 "Kyle" 100 }
+            T{ exam f 2 "Stan" 80 }
+            T{ exam f 3 "Kenny" 60 }
+        }
+    ] [
+        T{ exam f T{ range f 1 3 1 } } select-tuples
     ] unit-test ;
 
-[ test-ranges ] test-sqlite
+[ test-intervals ] test-sqlite
+
+: test-ranges
+    ;
 
 TUPLE: secret n message ;
 C: <secret> secret

extra/db/tuples/tuples.factor

@@ -22,6 +22,9 @@ IN: db.tuples
         class db-columns find-primary-key sql-spec-slot-name
     ] keep set-slot-named ;
 
+SYMBOL: sql-counter
+: next-sql-counter sql-counter [ inc ] [ get ] bi number>string ;
+
 ! returns a sequence of prepared-statements
 HOOK: create-sql-statement db ( class -- obj )
 HOOK: drop-sql-statement db ( class -- obj )

extra/db/types/types.factor

@@ -15,7 +15,8 @@ HOOK: compound-type db ( str n -- hash )
 
 TUPLE: sql-spec class slot-name column-name type modifiers primary-key ;
 
-TUPLE: literal-bind key value type ;
+TUPLE: literal-bind key type value ;
+C: <literal-bind> literal-bind
 
 SINGLETON: +native-id+
 SINGLETON: +assigned-id+
@@ -132,6 +133,7 @@ TUPLE: no-sql-modifier ;
     dup empty? [ " " prepend ] unless ;
 
 HOOK: bind% db ( spec -- )
+HOOK: bind# db ( spec obj -- )
 
 : offset-of-slot ( str obj -- n )
     class "slots" word-prop slot-named slot-spec-offset ;