refactor db

start on random-id

extra/db/db.factor

@@ -33,6 +33,19 @@ HOOK: db-close db ( handle -- )
 TUPLE: statement handle sql in-params out-params bind-params bound? ;
 TUPLE: simple-statement ;
 TUPLE: prepared-statement ;
+TUPLE: nonthrowable-statement ;
+: make-nonthrowable ( obj -- obj' )
+    dup sequence? [
+        [ make-nonthrowable ] map
+    ] [
+        nonthrowable-statement construct-delegate
+    ] if ;
+
+MIXIN: throwable-statement
+INSTANCE: statement throwable-statement
+INSTANCE: simple-statement throwable-statement
+INSTANCE: prepared-statement throwable-statement
+
 TUPLE: result-set sql in-params out-params handle n max ;
 : <statement> ( sql in out -- statement )
     { (>>sql) (>>in-params) (>>out-params) } statement construct ;
@@ -50,13 +63,22 @@ GENERIC# row-column-typed 1 ( result-set column -- sql )
 GENERIC: advance-row ( result-set -- )
 GENERIC: more-rows? ( result-set -- ? )
 
-: execute-statement ( statement -- )
+GENERIC: execute-statement ( statement -- )
+
+M: throwable-statement execute-statement ( statement -- )
     dup sequence? [
         [ execute-statement ] each
     ] [
         query-results dispose
     ] if ;
 
+M: nonthrowable-statement execute-statement ( statement -- )
+    dup sequence? [
+        [ execute-statement ] each
+    ] [
+        [ query-results dispose ] [ 2drop ] recover
+    ] if ;
+
 : bind-statement ( obj statement -- )
     swap >>bind-params
     [ bind-statement* ] keep

extra/db/postgresql/postgresql.factor

@@ -10,6 +10,7 @@ IN: db.postgresql
 
 TUPLE: postgresql-db host port pgopts pgtty db user pass ;
 TUPLE: postgresql-statement ;
+INSTANCE: postgresql-statement throwable-statement
 TUPLE: postgresql-result-set ;
 : <postgresql-statement> ( statement in out -- postgresql-statement )
     <statement>
@@ -194,7 +195,7 @@ M: postgresql-db <insert-native-statement> ( class -- statement )
         ");" 0%
     ] postgresql-make ;
 
-M: postgresql-db <insert-assigned-statement> ( class -- statement )
+M: postgresql-db <insert-nonnative-statement> ( class -- statement )
     [
         "insert into " 0% 0%
         "(" 0%

extra/db/sqlite/sqlite.factor

@@ -6,6 +6,7 @@ prettyprint sequences strings tuples alien.c-types
 continuations db.sqlite.lib db.sqlite.ffi db.tuples
 words combinators.lib db.types combinators
 combinators.cleave io namespaces.lib ;
+USE: tools.walker
 IN: db.sqlite
 
 TUPLE: sqlite-db path ;
@@ -22,6 +23,8 @@ M: sqlite-db dispose ( db -- ) dispose-db ;
 : with-sqlite ( path quot -- ) sqlite-db swap with-db ; inline
 
 TUPLE: sqlite-statement ;
+INSTANCE: sqlite-statement throwable-statement
+
 TUPLE: sqlite-result-set has-more? ;
 
 M: sqlite-db <simple-statement> ( str in out -- obj )
@@ -33,13 +36,20 @@ M: sqlite-db <prepared-statement> ( str in out -- obj )
         set-statement-in-params
         set-statement-out-params
     } statement construct
-    db get db-handle over statement-sql sqlite-prepare
-    over set-statement-handle
     sqlite-statement construct-delegate ;
 
+: sqlite-maybe-prepare ( statement -- statement )
+    dup statement-handle [
+        [
+            delegate
+            db get db-handle over statement-sql sqlite-prepare
+            swap set-statement-handle
+        ] keep
+    ] unless ;
+
 M: sqlite-statement dispose ( statement -- )
     statement-handle
-    [ sqlite3_reset drop ] keep sqlite-finalize ;
+    [ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;
 
 M: sqlite-result-set dispose ( result-set -- )
     f swap set-result-set-handle ;
@@ -47,9 +57,12 @@ M: sqlite-result-set dispose ( result-set -- )
 : sqlite-bind ( triples handle -- )
     swap [ first3 sqlite-bind-type ] with each ;
 
-: reset-statement ( statement -- ) statement-handle sqlite-reset ;
+: reset-statement ( statement -- )
+    sqlite-maybe-prepare
+    statement-handle sqlite-reset ;
 
 M: sqlite-statement bind-statement* ( statement -- )
+    sqlite-maybe-prepare
     dup statement-bound? [ dup reset-statement ] when
     [ statement-bind-params ] [ statement-handle ] bi
     sqlite-bind ;
@@ -90,6 +103,7 @@ M: sqlite-result-set more-rows? ( result-set -- ? )
     sqlite-result-set-has-more? ;
 
 M: sqlite-statement query-results ( query -- result-set )
+    sqlite-maybe-prepare
     dup statement-handle sqlite-result-set <result-set>
     dup advance-row ;
 
@@ -126,7 +140,7 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
         ");" 0%
     ] sqlite-make ;
 
-M: sqlite-db <insert-assigned-statement> ( tuple -- statement )
+M: sqlite-db <insert-nonnative-statement> ( tuple -- statement )
     <insert-native-statement> ;
 
 : where-primary-key% ( specs -- )
@@ -176,6 +190,7 @@ M: sqlite-db modifier-table ( -- hashtable )
     H{
         { +native-id+ "primary key" }
         { +assigned-id+ "primary key" }
+        ! { +nonnative-id+ "primary key" }
         { +autoincrement+ "autoincrement" }
         { +unique+ "unique" }
         { +default+ "default" }

extra/db/tuples/tuples-tests.factor

@@ -9,7 +9,7 @@ IN: db.tuples.tests
 TUPLE: person the-id the-name the-number the-real
 ts date time blob factor-blob ;
 
-: <person> ( name age real ts date time blob -- person )
+: <person> ( name age real ts date time blob factor-blob -- person )
     {
         set-person-the-name
         set-person-the-number
@@ -190,18 +190,16 @@ TUPLE: annotation n paste-id summary author mode contents ;
 : test-postgresql ( -- )
 >r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ;
 
-[ native-person-schema test-tuples ] test-sqlite
-[ assigned-person-schema test-tuples ] test-sqlite
-
 : test-repeated-insert
     [ ] [ person ensure-table ] unit-test
     
     [ ] [ person1 get insert-tuple ] unit-test
     [ person1 get insert-tuple ] must-fail ;
 
+[ native-person-schema test-tuples ] test-sqlite
+[ assigned-person-schema test-tuples ] test-sqlite
 [ native-person-schema test-tuples ] test-postgresql
 [ assigned-person-schema test-tuples ] test-postgresql
-
 [ assigned-person-schema test-repeated-insert ] test-sqlite
 [ assigned-person-schema test-repeated-insert ] test-postgresql
 

extra/db/tuples/tuples.factor

@@ -28,7 +28,7 @@ HOOK: create-sql-statement db ( class -- obj )
 HOOK: drop-sql-statement db ( class -- obj )
 
 HOOK: <insert-native-statement> db ( class -- obj )
-HOOK: <insert-assigned-statement> db ( class -- obj )
+HOOK: <insert-nonnative-statement> db ( class -- obj )
 
 HOOK: <update-tuple-statement> db ( class -- obj )
 HOOK: <update-tuples-statement> db ( class -- obj )
@@ -75,21 +75,25 @@ HOOK: insert-tuple* db ( tuple statement -- )
     drop-sql-statement [ execute-statement ] with-disposals ;
 
 : ensure-table ( class -- )
-    [ dup drop-table ] ignore-errors create-table ;
+    [
+        drop-sql-statement make-nonthrowable
+        [ execute-statement ] with-disposals
+    ] [ create-table ] bi ;
 
 : insert-native ( tuple -- )
     dup class
     db get db-insert-statements [ <insert-native-statement> ] cache
     [ bind-tuple ] 2keep insert-tuple* ;
 
-: insert-assigned ( tuple -- )
+: insert-nonnative ( tuple -- )
+! TODO logic here for unique ids
     dup class
-    db get db-insert-statements [ <insert-assigned-statement> ] cache
+    db get db-insert-statements [ <insert-nonnative-statement> ] cache
     [ bind-tuple ] keep execute-statement ;
 
 : insert-tuple ( tuple -- )
-    dup class db-columns find-primary-key assigned-id? [
-        insert-assigned
+    dup class db-columns find-primary-key nonnative-id? [
+        insert-nonnative
     ] [
         insert-native
     ] if ;

extra/db/types/types.factor

@@ -3,7 +3,8 @@
 USING: arrays assocs db kernel math math.parser
 sequences continuations sequences.deep sequences.lib
 words namespaces tools.walker slots slots.private classes
-mirrors tuples combinators calendar.format symbols ;
+mirrors tuples combinators calendar.format symbols
+singleton ;
 IN: db.types
 
 HOOK: modifier-table db ( -- hash )
@@ -14,22 +15,32 @@ HOOK: compound-type db ( str n -- hash )
 
 TUPLE: sql-spec class slot-name column-name type modifiers primary-key ;
 
-SYMBOLS: +native-id+ +assigned-id+ +autoincrement+
-+serial+ +unique+ +default+ +null+ +not-null+
+
+SINGLETON: +native-id+
+SINGLETON: +assigned-id+
+SINGLETON: +random-id+
+UNION: +primary-key+ +native-id+ +assigned-id+ +random-id+ ;
+UNION: +nonnative-id+ +random-id+ +assigned-id+ ;
+
+! +native-id+ +assigned-id+ +random-assigned-id+
+SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
 +foreign-id+ +has-many+ ;
 
-: (primary-key?) ( obj -- ? )
-    { +native-id+ +assigned-id+ } member? ;
-
 : primary-key? ( spec -- ? )
-    sql-spec-primary-key (primary-key?) ;
+    sql-spec-primary-key +primary-key+? ;
+
+: native-id? ( spec -- ? )
+    sql-spec-primary-key +native-id+? ;
+
+: nonnative-id? ( spec -- ? )
+    sql-spec-primary-key +nonnative-id+? ;
 
 : normalize-spec ( spec -- )
-    dup sql-spec-type dup (primary-key?) [
+    dup sql-spec-type dup +primary-key+? [
         swap set-sql-spec-primary-key
     ] [
         drop dup sql-spec-modifiers [
-            (primary-key?)
+            +primary-key+?
         ] deep-find
         [ swap set-sql-spec-primary-key ] [ drop ] if*
     ] if ;
@@ -37,12 +48,6 @@ SYMBOLS: +native-id+ +assigned-id+ +autoincrement+
 : find-primary-key ( specs -- obj )
     [ sql-spec-primary-key ] find nip ;
 
-: native-id? ( spec -- ? )
-    sql-spec-primary-key +native-id+ = ;
-
-: assigned-id? ( spec -- ? )
-    sql-spec-primary-key +assigned-id+ = ;
-
 : relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
 
 SYMBOLS: INTEGER BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR
@@ -69,7 +74,7 @@ TUPLE: no-sql-modifier ;
     dup number? [ number>string ] when ;
 
 : maybe-remove-id ( specs -- obj )
-    [ native-id? not ] subset ;
+    [ +native-id+? not ] subset ;
 
 : remove-relations ( specs -- newcolumns )
     [ relation? not ] subset ;