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

basis/db/queries/queries.factor

@@ -168,7 +168,7 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
         number>string " limit " swap 3append
     ] curry change-sql drop ;
 
-: make-query ( tuple query -- tuple' )
+: make-query* ( tuple query -- tuple' )
     dupd
     {
         [ group>> [ drop ] [ do-group ] if-empty ]
@@ -177,8 +177,8 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
         [ offset>> [ do-offset ] [ drop ] if* ]
     } 2cleave ;
 
-M: db <query> ( tuple class query -- tuple )
+M: db make-query ( tuple class query -- tuple )
-    [ <select-by-slots-statement> ] dip make-query ;
+    [ <select-by-slots-statement> ] dip make-query* ;
 
 ! select ID, NAME, SCORE from EXAM limit 1 offset 3
 
@@ -198,7 +198,7 @@ M: db <count-statement> ( tuple class groups -- statement )
     \ query new
         swap >>group
     [ [ "select count(*) from " 0% 0% where-clause ] query-make ]
-    dip make-query ;
+    dip make-query* ;
 
 : create-index ( index-name table-name columns -- )
     [

basis/db/tuples/tuples-tests.factor

@@ -236,6 +236,17 @@ TUPLE: exam id name score ;
     exam boa ;
 
 : test-intervals ( -- )
+    [
+        exam "EXAM"
+        {
+            { "idd" "ID" +db-assigned-id+ }
+            { "named" "NAME" TEXT }
+            { "score" "SCORE" INTEGER }
+        } define-persistent
+    ] [
+        seq>> { "idd" "named" } =
+    ] must-fail-with
+
     exam "EXAM"
     {
         { "id" "ID" +db-assigned-id+ }
@@ -499,3 +510,17 @@ string-encoding-test "STRING_ENCODING_TEST" {
 \ ensure-table must-infer
 \ create-table must-infer
 \ drop-table must-infer
+
+: test-queries ( -- )
+    [ ] [ exam ensure-table ] unit-test
+    ! [ ] [ T{ exam f f "Kyle" 100 } insert-tuple ] unit-test
+    ! [ ] [ T{ exam f f "Stan" 80 } insert-tuple ] unit-test
+    ! [ ] [ T{ exam f f "Kenny" 60 } insert-tuple ] unit-test
+    ! [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test
+    [ ] [ 10 [ random-exam insert-tuple ] times ] unit-test
+    ! [ ] [ T{ exam { name "Kenny" } } >query  ] unit-test
+    ! [ ] [ query ] unit-test
+    ;
+
+: test-db ( -- )
+    "tuples-test.db" temp-file sqlite-db make-db db-open db set ;

basis/db/tuples/tuples.factor

@@ -3,11 +3,44 @@
 USING: arrays assocs classes db kernel namespaces
 classes.tuple words sequences slots math accessors
 math.parser io prettyprint db.types continuations
-destructors mirrors ;
+destructors mirrors sets ;
 IN: db.tuples
 
+TUPLE: query tuple group order offset limit ;
+
+: <query> ( -- query ) \ query new ;
+
+GENERIC: >query ( object -- query )
+
+M: query >query ;
+
+M: tuple >query <query> swap >>tuple ;
+
+! returns a sequence of prepared-statements
+HOOK: create-sql-statement db ( class -- object )
+HOOK: drop-sql-statement db ( class -- object )
+
+HOOK: <insert-db-assigned-statement> db ( class -- object )
+HOOK: <insert-user-assigned-statement> db ( class -- object )
+HOOK: <update-tuple-statement> db ( class -- object )
+HOOK: <delete-tuples-statement> db ( tuple class -- object )
+HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
+HOOK: <count-statement> db ( tuple class groups -- statement )
+HOOK: make-query db ( tuple class query -- statement )
+
+HOOK: insert-tuple* db ( tuple statement -- )
+
+ERROR: no-slots-named class seq ;
+: check-columns ( class columns -- )
+    tuck
+    [ [ first ] map ]
+    [ "slots" word-prop [ name>> ] map ] bi* diff
+    [ drop ] [ no-slots-named ] if-empty ;
+
 : define-persistent ( class table columns -- )
-    >r dupd "db-table" set-word-prop dup r>
+    pick dupd
+    check-columns
+    [ dupd "db-table" set-word-prop dup ] dip
     [ relation? ] partition swapd
     dupd [ spec>tuple ] with map
     "db-columns" set-word-prop
@@ -33,21 +66,6 @@ SYMBOL: sql-counter
 : next-sql-counter ( -- str )
     sql-counter [ inc ] [ get ] bi number>string ;
 
-! returns a sequence of prepared-statements
-HOOK: create-sql-statement db ( class -- object )
-HOOK: drop-sql-statement db ( class -- object )
-
-HOOK: <insert-db-assigned-statement> db ( class -- object )
-HOOK: <insert-user-assigned-statement> db ( class -- object )
-HOOK: <update-tuple-statement> db ( class -- object )
-HOOK: <delete-tuples-statement> db ( tuple class -- object )
-HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
-TUPLE: query group order offset limit ;
-HOOK: <query> db ( tuple class query -- statement' )
-HOOK: <count-statement> db ( tuple class groups -- n )
-
-HOOK: insert-tuple* db ( tuple statement -- )
-
 GENERIC: eval-generator ( singleton -- object )
 
 : resulting-tuple ( exemplar-tuple row out-params -- tuple )
@@ -121,13 +139,14 @@ GENERIC: eval-generator ( singleton -- object )
     [ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
 
 : query ( tuple query -- tuples )
-    [ dup dup class ] dip <query> do-select ;
+    [ dup dup class ] dip make-query do-select ;
+
 
 : select-tuples ( tuple -- tuples )
     dup dup class <select-by-slots-statement> do-select ;
 
 : select-tuple ( tuple -- tuple/f )
-    dup dup class \ query new 1 >>limit <query> do-select
+    dup dup class \ query new 1 >>limit make-query do-select
     [ f ] [ first ] if-empty ;
 
 : do-count ( exemplar-tuple statement -- tuples )