make throwable, nonthrowable, retryable a type

extra/db/db.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs classes continuations kernel math
 namespaces sequences sequences.lib classes.tuple words strings
-tools.walker accessors ;
+tools.walker accessors combinators.lib ;
 IN: db
 
 TUPLE: db
@@ -36,26 +36,47 @@ HOOK: db-close db ( handle -- )
     ] with-variable ;
 
 ! TUPLE: sql sql in-params out-params ;
-TUPLE: statement handle sql in-params out-params bind-params bound? ;
+TUPLE: statement handle sql in-params out-params bind-params bound? type quot ;
 TUPLE: simple-statement < statement ;
 TUPLE: prepared-statement < statement ;
-TUPLE: nonthrowable-statement < statement ;
-TUPLE: throwable-statement < statement ;
+
+SINGLETON: throwable
+SINGLETON: nonthrowable
+SINGLETON: retryable
+
+: make-throwable ( obj -- obj' )
+    dup sequence? [
+        [ make-throwable ] map
+    ] [
+        throwable >>type
+    ] if ;
 
 : make-nonthrowable ( obj -- obj' )
     dup sequence? [
         [ make-nonthrowable ] map
     ] [
-        nonthrowable-statement construct-delegate
+        nonthrowable >>type
     ] if ;
 
+: make-retryable ( obj quot -- obj' )
+    over sequence? [
+        [ make-retryable ] curry map
+    ] [
+        >>quot
+        retryable >>type
+    ] if ;
+
+: handle-random-id ( statement -- )
+    drop ;
+
 TUPLE: result-set sql in-params out-params handle n max ;
 
 : construct-statement ( sql in out class -- statement )
     new
         swap >>out-params
         swap >>in-params
-        swap >>sql ;
+        swap >>sql
+        throwable >>type ;
 
 HOOK: <simple-statement> db ( str in out -- statement )
 HOOK: <prepared-statement> db ( str in out -- statement )
@@ -70,20 +91,25 @@ GENERIC# row-column-typed 1 ( result-set column -- sql )
 GENERIC: advance-row ( result-set -- )
 GENERIC: more-rows? ( result-set -- ? )
 
-GENERIC: execute-statement ( statement -- )
+GENERIC: execute-statement* ( statement type -- )
 
-M: throwable-statement execute-statement ( statement -- )
-    dup sequence? [
-        [ execute-statement ] each
-    ] [
-        query-results dispose
-    ] if ;
+M: throwable execute-statement* ( statement type -- )
+    drop query-results dispose ;
 
-M: nonthrowable-statement execute-statement ( statement -- )
-    dup sequence? [
-        [ execute-statement ] each
-    ] [
+M: nonthrowable execute-statement* ( statement type -- )
+    drop [ query-results dispose ] [ 2drop ] recover ;
+
+M: retryable execute-statement* ( statement type -- )
+    [
+        dup dup quot>> call
         [ query-results dispose ] [ 2drop ] recover
+    ] curry 10 retry ;
+
+: execute-statement ( statement -- )
+    dup sequence? [
+        [ execute-statement ] each
+    ] [
+        dup type>> execute-statement*
     ] if ;
 
 : bind-statement ( obj statement -- )

extra/db/postgresql/postgresql.factor

@@ -11,7 +11,7 @@ IN: db.postgresql
 TUPLE: postgresql-db < db
     host port pgopts pgtty db user pass ;
 
-TUPLE: postgresql-statement < throwable-statement ;
+TUPLE: postgresql-statement < statement ;
 
 TUPLE: postgresql-result-set < result-set ;
 

extra/db/sqlite/sqlite.factor

@@ -20,7 +20,7 @@ M: sqlite-db db-open ( db -- db )
 M: sqlite-db db-close ( handle -- ) sqlite-close ;
 M: sqlite-db dispose ( db -- ) dispose-db ;
 
-TUPLE: sqlite-statement < throwable-statement ;
+TUPLE: sqlite-statement < statement ;
 
 TUPLE: sqlite-result-set < result-set has-more? ;
 
@@ -105,7 +105,8 @@ M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
 : sqlite-make ( class quot -- )
     >r sql-props r>
     [ 0 sql-counter rot with-variable ] { "" { } { } } nmake
-    <simple-statement> ; inline
+    <simple-statement>
+    dup handle-random-id ; inline
 
 M: sqlite-db create-sql-statement ( class -- statement )
     [
@@ -223,7 +224,6 @@ M: sqlite-db modifier-table ( -- hashtable )
         { +native-id+ "primary key" }
         { +assigned-id+ "primary key" }
         { +random-id+ "primary key" }
-        ! { +nonnative-id+ "primary key" }
         { +autoincrement+ "autoincrement" }
         { +unique+ "unique" }
         { +default+ "default" }
@@ -236,7 +236,7 @@ M: sqlite-db compound-modifier ( str obj -- str' ) compound-type ;
 M: sqlite-db compound-type ( str seq -- str' )
     over {
         { "default" [ first number>string join-space ] }
-        [ 2drop ] !  "no sqlite compound data type" 3array throw ]
+        [ 2drop ] 
     } case ;
 
 M: sqlite-db type-table ( -- assoc )

extra/db/tuples/tuples-tests.factor

@@ -308,15 +308,13 @@ C: <secret> secret
     [ ] [ T{ secret } select-tuples ] unit-test
     ;
 
-
-
-! [ test-random-id ] test-sqlite
- [ native-person-schema test-tuples ] test-sqlite
- [ assigned-person-schema test-tuples ] test-sqlite
- [ assigned-person-schema test-repeated-insert ] test-sqlite
- [ native-person-schema test-tuples ] test-postgresql
- [ assigned-person-schema test-tuples ] test-postgresql
- [ assigned-person-schema test-repeated-insert ] test-postgresql
+[ test-random-id ] test-sqlite
+[ native-person-schema test-tuples ] test-sqlite
+[ assigned-person-schema test-tuples ] test-sqlite
+[ assigned-person-schema test-repeated-insert ] test-sqlite
+[ native-person-schema test-tuples ] test-postgresql
+[ assigned-person-schema test-tuples ] test-postgresql
+[ assigned-person-schema test-repeated-insert ] test-postgresql
 
 ! \ insert-tuple must-infer
 ! \ update-tuple must-infer