Merge branch 'master' of git://factorcode.org/git/factor

extra/db/queries/queries.factor

@@ -15,7 +15,7 @@ GENERIC: where ( specs obj -- )
 
 : query-make ( class quot -- )
     >r sql-props r>
-    [ 0 sql-counter rot with-variable ] { "" { } { } } nmake
+    [ 0 sql-counter rot with-variable ";" 0% ] { "" { } { } } nmake
     <simple-statement> maybe-make-retryable ; inline
 
 M: db begin-transaction ( -- ) "BEGIN" sql-command ;
@@ -44,18 +44,40 @@ M: random-id-generator eval-generator ( singleton -- obj )
 : interval-comparison ( ? str -- str )
     "from" = " >" " <" ? swap [ "= " append ] when ;
 
+: fp-infinity? ( float -- ? )
+    dup float? [
+        double>bits -52 shift 11 2^ 1- [ bitand ] keep =
+    ] [
+        drop f
+    ] if ;
+
+: (infinite-interval?) ( interval -- ?1 ?2 )
+    [ from>> ] [ to>> ] bi
+    [ first fp-infinity? ] bi@ ;
+
+: double-infinite-interval? ( obj -- ? )
+    dup interval? [ (infinite-interval?) and ] [ drop f ] if ;
+
+: infinite-interval? ( obj -- ? )
+    dup interval? [ (infinite-interval?) or ] [ drop f ] if ;
+
 : where-interval ( spec obj from/to -- )
-    pick column-name>> 0%
+    over first fp-infinity? [
-    >r first2 r> interval-comparison 0%
+        3drop
-    bind# ;
+    ] [
+        pick column-name>> 0%
+        >r first2 r> interval-comparison 0%
+        bind#
+    ] if ;
 
 : in-parens ( quot -- )
     "(" 0% call ")" 0% ; inline
 
 M: interval where ( spec obj -- )
     [
-        [ from>> "from" where-interval " and " 0% ]
+        [ from>> "from" where-interval ] [
-        [ to>> "to" where-interval ] 2bi
+            nip infinite-interval? [ " and " 0% ] unless
+        ] [ to>> "to" where-interval ] 2tri
     ] in-parens ;
 
 M: sequence where ( spec obj -- )
@@ -72,19 +94,28 @@ M: integer where ( spec obj -- ) object-where ;
 
 M: string where ( spec obj -- ) object-where ;
 
+: filter-slots ( tuple specs -- specs' )
+    [
+        slot-name>> swap get-slot-named
+        dup double-infinite-interval? [ drop f ] when
+    ] with filter ;
+
 : where-clause ( tuple specs -- )
-    " where " 0% [
+    dupd filter-slots
-        " and " 0%
+    dup empty? [
+        2drop
     ] [
-        2dup slot-name>> swap get-slot-named where
+        " where " 0% [
-    ] interleave drop ;
+            " and " 0%
+        ] [
+            2dup slot-name>> swap get-slot-named where
+        ] interleave drop
+    ] if ;
 
 M: db <delete-tuple-statement> ( tuple table -- sql )
     [
         "delete from " 0% 0%
-        dupd
+        where-clause
-        [ slot-name>> swap get-slot-named ] with filter
-        dup empty? [ 2drop ] [ where-clause ] if ";" 0%
     ] query-make ;
 
 M: db <select-by-slots-statement> ( tuple class -- statement )
@@ -94,7 +125,5 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
         [ dup column-name>> 0% 2, ] interleave
 
         " from " 0% 0%
-        dupd
+        where-clause
-        [ slot-name>> swap get-slot-named ] with filter
-        dup empty? [ 2drop ] [ where-clause ] if ";" 0%
     ] query-make ;

extra/db/sql/sql.factor

@@ -1,7 +1,6 @@
 USING: kernel parser quotations classes.tuple words math.order
 namespaces.lib namespaces sequences arrays combinators
 prettyprint strings math.parser sequences.lib math symbols ;
-USE: tools.walker
 IN: db.sql
 
 SYMBOLS: insert update delete select distinct columns from as

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 io.backend ;
+io.backend ;
 IN: db.sqlite.lib
 
 : sqlite-error ( n -- * )

extra/db/tuples/tuples-tests.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io.files kernel tools.test db db.tuples classes
 db.types continuations namespaces math math.ranges
-prettyprint tools.walker calendar sequences db.sqlite
+prettyprint calendar sequences db.sqlite math.intervals
-math.intervals db.postgresql accessors random math.bitfields.lib ;
+db.postgresql accessors random math.bitfields.lib ;
 IN: db.tuples.tests
 
 TUPLE: person the-id the-name the-number the-real
@@ -30,6 +30,7 @@ SYMBOL: person3
 SYMBOL: person4
 
 : test-tuples ( -- )
+    [ ] [ person recreate-table ] unit-test
     [ ] [ person ensure-table ] unit-test
     [ ] [ person drop-table ] unit-test
     [ ] [ person create-table ] unit-test
@@ -292,6 +293,46 @@ TUPLE: exam id name score ;
         }
     ] [
         T{ exam f T{ range f 1 3 1 } } select-tuples
+    ] unit-test
+
+    [
+        {
+            T{ exam f 2 "Stan" 80 }
+            T{ exam f 3 "Kenny" 60 }
+            T{ exam f 4 "Cartman" 41 }
+        }
+    ] [
+        T{ exam f T{ interval f { 2 t } { 1.0/0.0 f } } } select-tuples
+    ] unit-test
+
+    [
+        {
+            T{ exam f 1 "Kyle" 100 }
+        }
+    ] [
+        T{ exam f T{ interval f { -1.0/0.0 t } { 2 f } } } 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 4 "Cartman" 41 }
+        }
+    ] [
+        T{ exam f T{ interval f { -1.0/0.0 t } { 1/0. f } } } 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 4 "Cartman" 41 }
+        }
+    ] [
+        T{ exam } select-tuples
     ] unit-test ;
 
 TUPLE: bignum-test id m n o ;
@@ -328,7 +369,7 @@ C: <secret> secret
         { "message" "MESSAGE" TEXT }
     } define-persistent
 
-    [ ] [ secret ensure-table ] unit-test
+    [ ] [ secret recreate-table ] unit-test
 
     [ t ] [ f "kilroy was here" <secret> [ insert-tuple ] keep n>> integer? ] unit-test
 
@@ -342,7 +383,7 @@ C: <secret> secret
     ] unit-test
 
     [ t ] [
-        T{ secret } select-tuples dup . length 3 =
+        T{ secret } select-tuples length 3 =
     ] unit-test ;
 
 [ db-assigned-person-schema test-tuples ] test-sqlite

extra/db/tuples/tuples.factor

@@ -3,7 +3,7 @@
 USING: arrays assocs classes db kernel namespaces
 classes.tuple words sequences slots math accessors
 math.parser io prettyprint db.types continuations
-mirrors sequences.lib tools.walker combinators.lib ;
+mirrors sequences.lib combinators.lib ;
 IN: db.tuples
 
 : define-persistent ( class table columns -- )
@@ -108,12 +108,15 @@ M: retryable execute-statement* ( statement type -- )
 : drop-table ( class -- )
     drop-sql-statement [ execute-statement ] with-disposals ;
 
-: ensure-table ( class -- )
+: recreate-table ( class -- )
     [
         drop-sql-statement make-nonthrowable
         [ execute-statement ] with-disposals
     ] [ create-table ] bi ;
 
+: ensure-table ( class -- )
+    [ create-table ] curry ignore-errors ;
+
 : insert-db-assigned-statement ( tuple -- )
     dup class
     db get db-insert-statements [ <insert-db-assigned-statement> ] cache

extra/db/types/types.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs db kernel math math.parser
 sequences continuations sequences.deep sequences.lib
-words namespaces tools.walker slots slots.private classes
+words namespaces slots slots.private classes mirrors
-mirrors classes.tuple combinators calendar.format symbols
+classes.tuple combinators calendar.format symbols
 classes.singleton accessors quotations random ;
 IN: db.types