add interval queries for sqlite

extra/db/db.factor

@@ -11,7 +11,7 @@ TUPLE: db
     update-statements
     delete-statements ;
 
-: construct-db ( class -- obj )
+: new-db ( class -- obj )
     new
         H{ } clone >>insert-statements
         H{ } clone >>update-statements
@@ -20,7 +20,7 @@ TUPLE: db
 GENERIC: make-db* ( seq class -- db )
 
 : make-db ( seq class -- db )
-    construct-db make-db* ;
+    new-db make-db* ;
 
 GENERIC: db-open ( db -- db )
 HOOK: db-close db ( handle -- )

extra/db/sql/sql-tests.factor

@@ -1,7 +1,7 @@
 USING: kernel namespaces db.sql sequences math ;
 IN: db.sql.tests
 
-TUPLE: person name age ;
+! TUPLE: person name age ;
 : insert-1
     { insert
         { table "person" }

extra/db/sql/sql.factor

@@ -55,15 +55,18 @@ TUPLE: no-sql-match ;
         { [ dup number? ] [ number>string sql% ] }
         { [ dup symbol? ] [ unparse sql% ] }
         { [ dup word? ] [ unparse sql% ] }
+        { [ dup quotation? ] [ call ] }
         [ T{ no-sql-match } throw ]
     } cond ;
 
 : parse-sql ( obj -- sql in-spec out-spec in out )
     [
         unclip {
-            { insert [ "insert into" sql% ] }
+            { \ create [ "create table" sql% ] }
-            { update [ "update" sql% ] }
+            { \ drop [ "drop table" sql% ] }
-            { delete [ "delete" sql% ] }
+            { \ insert [ "insert into" sql% ] }
-            { select [ "select" sql% ] }
+            { \ update [ "update" sql% ] }
+            { \ delete [ "delete" sql% ] }
+            { \ select [ "select" sql% ] }
         } case [ sql% ] each
     ] { "" { } { } { } { } } nmake ;

extra/db/sqlite/lib/lib.factor

@@ -4,7 +4,7 @@ USING: alien.c-types arrays assocs kernel math math.parser
 namespaces sequences db.sqlite.ffi db combinators
 continuations db.types calendar.format serialize
 io.streams.byte-array byte-arrays io.encodings.binary
-tools.walker ;
+tools.walker io.backend ;
 IN: db.sqlite.lib
 
 : sqlite-error ( n -- * )
@@ -23,7 +23,8 @@ IN: db.sqlite.lib
         [ sqlite-error ]
     } cond ;
 
-: sqlite-open ( filename -- db )
+: sqlite-open ( path -- db )
+    normalize-path
     "void*" <c-object>
     [ sqlite3_open sqlite-check-result ] keep *void* ;
 

extra/db/sqlite/sqlite.factor

@@ -4,8 +4,9 @@ USING: alien arrays assocs classes compiler db
 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
+words combinators.lib db.types combinators math.intervals
 io namespaces.lib accessors ;
+USE: tools.walker
 IN: db.sqlite
 
 TUPLE: sqlite-db < db path ;
@@ -54,16 +55,20 @@ M: sqlite-statement bind-statement* ( statement -- )
     [ statement-bind-params ] [ statement-handle ] bi
     sqlite-bind ;
 
+GENERIC: sqlite-bind-conversion ( tuple obj -- array )
+
+M: sql-spec sqlite-bind-conversion ( tuple spec -- array )
+    [ column-name>> ":" prepend ]
+    [ slot-name>> rot get-slot-named ]
+    [ type>> ] tri 3array ;
+
+M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array )
+    nip [ key>> ] [ value>> ] [ type>> ] tri 3array ;
+
 M: sqlite-statement bind-tuple ( tuple statement -- )
     [
-        in-params>>
+        in-params>> [ sqlite-bind-conversion ] with map
-        [
+    ] keep bind-statement ;
-            [ column-name>> ":" prepend ]
-            [ slot-name>> rot get-slot-named ]
-            [ type>> ] tri 3array
-        ] with map
-    ] keep
-    bind-statement ;
 
 : last-insert-id ( -- id )
     db get db-handle sqlite3_last_insert_rowid
@@ -129,13 +134,46 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
 M: sqlite-db <insert-nonnative-statement> ( tuple -- statement )
     <insert-native-statement> ;
 
+M: sqlite-db bind% ( spec -- )
+    dup 1, column-name>> ":" prepend 0% ;
+
 : where-primary-key% ( specs -- )
     " where " 0%
     find-primary-key dup column-name>> 0% " = " 0% bind% ;
 
-: where-clause ( specs -- )
+! : where-object ( tuple specs -- )
-    " where " 0%
+    ! [ dup column-name>> get-slot-named ] keep
-    [ " and " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave ;
+    ! dup column-name>> 0% " = " 0% bind% ;
+
+GENERIC: where-object ( 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, ;
+
+M: interval where-object ( specs obj -- )
+    [ from>> first2 "from" where-interval " and " 0% ]
+    [ to>> first2 "to" where-interval ] 2bi ;
+
+M: object where-object ( specs obj -- )
+    drop
+    dup column-name>> 0% " = " 0% bind% ;
+
+: where-clause ( tuple specs -- )
+    " where " 0% [
+        " and " 0%
+    ] [
+        2dup slot-name>> swap get-slot-named where-object
+    ] interleave drop ;
 
 M: sqlite-db <update-tuple-statement> ( class -- statement )
     [
@@ -158,9 +196,6 @@ M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
 ! : select-interval ( interval name -- ) ;
 ! : select-sequence ( seq name -- ) ;
 
-M: sqlite-db bind% ( spec -- )
-    dup 1, column-name>> ":" prepend 0% ;
-
 M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
     [
         "select " 0%
@@ -168,8 +203,9 @@ M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
         [ dup column-name>> 0% 2, ] interleave
 
         " from " 0% 0%
+        dupd
         [ slot-name>> swap get-slot-named ] with subset
-        dup empty? [ drop ] [ where-clause ] if ";" 0%
+        dup empty? [ 2drop ] [ where-clause ] if ";" 0%
     ] sqlite-make ;
 
 M: sqlite-db modifier-table ( -- hashtable )

extra/db/tuples/tuples-tests.factor

@@ -233,12 +233,43 @@ TUPLE: exam id name score ;
     [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test
 
     [
-        T{ exam f 3 "Kenny" 60 }
+        {
-        T{ exam f 4 "Cartman" 41 }
+            T{ exam f 3 "Kenny" 60 }
-    ] [ T{ exam f 4 f T{ interval f { 0 t } { 70 t } } } select-tuples ] unit-test
+            T{ exam f 4 "Cartman" 41 }
-    ;
+        }
+    ] [
+        T{ exam f f f T{ interval f { 0 t } { 70 t } } } select-tuples
+    ] unit-test
 
-! [ test-ranges ] test-sqlite
+    [
+        { }
+    ] [
+        T{ exam f T{ interval f { 3 f } { 4 f } } f } select-tuples
+    ] unit-test
+    [
+        {
+            T{ exam f 4 "Cartman" 41 }
+        }
+    ] [
+        T{ exam f T{ interval f { 3 f } { 4 t } } f } select-tuples
+    ] unit-test
+    [
+        {
+            T{ exam f 3 "Kenny" 60 }
+        }
+    ] [
+        T{ exam f T{ interval f { 3 t } { 4 f } } f } select-tuples
+    ] unit-test
+    [
+        {
+            T{ exam f 3 "Kenny" 60 }
+            T{ exam f 4 "Cartman" 41 }
+        }
+    ] [
+        T{ exam f T{ interval f { 3 t } { 4 t } } f } select-tuples
+    ] unit-test ;
+
+[ test-ranges ] test-sqlite
 
 TUPLE: secret n message ;
 C: <secret> secret

extra/db/types/types.factor

@@ -15,6 +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 ;
+
 SINGLETON: +native-id+
 SINGLETON: +assigned-id+
 SINGLETON: +random-id+