From 93bf51eb68f2beb0e472821cc1843e46991d1e31 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 28 Apr 2008 18:21:45 -0500
Subject: [PATCH 1/5] ensure-table just does [ create-table ] curry
ignore-errors recreate-table is the old ensure-table
---
extra/db/sql/sql.factor | 1 -
extra/db/sqlite/lib/lib.factor | 2 +-
extra/db/tuples/tuples-tests.factor | 8 ++++----
extra/db/tuples/tuples.factor | 7 +++++--
extra/db/types/types.factor | 4 ++--
5 files changed, 12 insertions(+), 10 deletions(-)
diff --git a/extra/db/sql/sql.factor b/extra/db/sql/sql.factor
index 184c45f8b1..82c6e370bd 100755
--- a/extra/db/sql/sql.factor
+++ b/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
diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor
index f25ec12d1b..e92c4bbd8a 100755
--- a/extra/db/sqlite/lib/lib.factor
+++ b/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 -- * )
diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
index f5f229bfd2..5fbf8a58d4 100755
--- a/extra/db/tuples/tuples-tests.factor
+++ b/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
-math.intervals db.postgresql accessors random math.bitfields.lib ;
+prettyprint calendar sequences db.sqlite math.intervals
+db.postgresql accessors random math.bitfields.lib ;
IN: db.tuples.tests
TUPLE: person the-id the-name the-number the-real
@@ -328,7 +328,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 +342,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
diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor
index afea61fc90..835b4b45d3 100755
--- a/extra/db/tuples/tuples.factor
+++ b/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
diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor
index 8328bd7626..8dbf6786bc 100755
--- a/extra/db/types/types.factor
+++ b/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
-mirrors classes.tuple combinators calendar.format symbols
+words namespaces slots slots.private classes mirrors
+classes.tuple combinators calendar.format symbols
classes.singleton accessors quotations random ;
IN: db.types
From d213150834625716c528788ee7c5efe5663adec9 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 28 Apr 2008 18:41:53 -0500
Subject: [PATCH 2/5] fix unit test
---
extra/db/tuples/tuples-tests.factor | 1 +
1 file changed, 1 insertion(+)
diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
index 5fbf8a58d4..81a402ee5d 100755
--- a/extra/db/tuples/tuples-tests.factor
+++ b/extra/db/tuples/tuples-tests.factor
@@ -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
From b092a4f9d5d6ad3f8cefe848d5742884f0e9b605 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 28 Apr 2008 19:41:35 -0500
Subject: [PATCH 3/5] add support for infinity to intervals
---
extra/db/queries/queries.factor | 33 +++++++++++++++++++++++------
extra/db/tuples/tuples-tests.factor | 29 +++++++++++++++++++++++++
2 files changed, 55 insertions(+), 7 deletions(-)
diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor
index 7f3eaff84c..9ee44ffeed 100644
--- a/extra/db/queries/queries.factor
+++ b/extra/db/queries/queries.factor
@@ -44,19 +44,38 @@ 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 ;
+
: where-interval ( spec obj from/to -- )
- pick column-name>> 0%
- >r first2 r> interval-comparison 0%
- bind# ;
+ over first fp-infinity? [
+ 3drop
+ ] [
+ 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% ]
- [ to>> "to" where-interval ] 2bi
- ] in-parens ;
+ dup [ from>> ] [ to>> ] bi
+ [ first fp-infinity? ] bi@ and [
+ 2drop
+ " 1 = 1 " 0% ! dummy
+ ] [
+ [
+ [ from>> "from" where-interval ] [
+ nip [ from>> ] [ to>> ] bi
+ [ first fp-infinity? ] bi@ or [ " and " 0% ] unless
+ ] [ to>> "to" where-interval ] 2tri
+ ] in-parens
+ ] if ;
M: sequence where ( spec obj -- )
[
diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
index 81a402ee5d..2b73b5c4fe 100755
--- a/extra/db/tuples/tuples-tests.factor
+++ b/extra/db/tuples/tuples-tests.factor
@@ -293,6 +293,35 @@ 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 ;
TUPLE: bignum-test id m n o ;
From e26648002911fd6e2a2ee7bf24ea47d23b2752fa Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 28 Apr 2008 20:01:32 -0500
Subject: [PATCH 4/5] beginning to refactor
---
extra/db/queries/queries.factor | 2 ++
extra/db/tuples/tuples-tests.factor | 11 +++++++++++
2 files changed, 13 insertions(+)
diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor
index 9ee44ffeed..cbbd8fd9a0 100644
--- a/extra/db/queries/queries.factor
+++ b/extra/db/queries/queries.factor
@@ -6,6 +6,8 @@ math.bitfields.lib namespaces.lib db db.tuples db.types
math.intervals ;
IN: db.queries
+TUPLE: query tuple order group having ;
+
GENERIC: where ( specs obj -- )
: maybe-make-retryable ( statement -- statement )
diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
index 2b73b5c4fe..8e6b9bfbe4 100755
--- a/extra/db/tuples/tuples-tests.factor
+++ b/extra/db/tuples/tuples-tests.factor
@@ -322,6 +322,17 @@ TUPLE: exam id name score ;
}
] [
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 ;
From 913da8f2ea201e33b13b1a0fba98691c88f3cfe3 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 28 Apr 2008 20:27:37 -0500
Subject: [PATCH 5/5] refactor where-clause
---
extra/db/queries/queries.factor | 58 +++++++++++++++++++--------------
1 file changed, 33 insertions(+), 25 deletions(-)
diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor
index cbbd8fd9a0..43ca4f369c 100644
--- a/extra/db/queries/queries.factor
+++ b/extra/db/queries/queries.factor
@@ -6,8 +6,6 @@ math.bitfields.lib namespaces.lib db db.tuples db.types
math.intervals ;
IN: db.queries
-TUPLE: query tuple order group having ;
-
GENERIC: where ( specs obj -- )
: maybe-make-retryable ( statement -- statement )
@@ -17,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 ;
@@ -53,6 +51,16 @@ M: random-id-generator eval-generator ( singleton -- obj )
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 -- )
over first fp-infinity? [
3drop
@@ -66,18 +74,11 @@ M: random-id-generator eval-generator ( singleton -- obj )
"(" 0% call ")" 0% ; inline
M: interval where ( spec obj -- )
- dup [ from>> ] [ to>> ] bi
- [ first fp-infinity? ] bi@ and [
- 2drop
- " 1 = 1 " 0% ! dummy
- ] [
- [
- [ from>> "from" where-interval ] [
- nip [ from>> ] [ to>> ] bi
- [ first fp-infinity? ] bi@ or [ " and " 0% ] unless
- ] [ to>> "to" where-interval ] 2tri
- ] in-parens
- ] if ;
+ [
+ [ from>> "from" where-interval ] [
+ nip infinite-interval? [ " and " 0% ] unless
+ ] [ to>> "to" where-interval ] 2tri
+ ] in-parens ;
M: sequence where ( spec obj -- )
[
@@ -93,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% [
- " and " 0%
+ dupd filter-slots
+ dup empty? [
+ 2drop
] [
- 2dup slot-name>> swap get-slot-named where
- ] interleave drop ;
+ " where " 0% [
+ " 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
- [ slot-name>> swap get-slot-named ] with filter
- dup empty? [ 2drop ] [ where-clause ] if ";" 0%
+ where-clause
] query-make ;
M: db <select-by-slots-statement> ( tuple class -- statement )
@@ -115,7 +125,5 @@ M: 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 filter
- dup empty? [ 2drop ] [ where-clause ] if ";" 0%
+ where-clause
] query-make ;