more work on libs/sql

diff --git a/libs/sql/execute.factor b/libs/sql/execute.factor
index 00ad16304d93305b5872482223c98a55824148e6..38bf53fd4f367119b4f999961185148d60e67f6d 100644 (file)
--- a/libs/sql/execute.factor
+++ b/libs/sql/execute.factor
@@ -1,10 +1,47 @@
-USING: kernel namespaces ;\r
+USING: errors generic kernel namespaces sql:utils ;\r
 IN: sql\r
 \r
-GENERIC: execute-sql* ( string db -- )\r
-GENERIC: query-sql* ( string db -- seq )\r
+G: execute-sql* ( db string -- ) 1 standard-combination ; \r
+G: query-sql* ( db string -- seq ) 1 standard-combination ; \r
 \r
-: execute-sql ( string -- ) db get execute-sql* ;\r
-: query-sql ( string -- ) db get query-sql* ;\r
+: execute-sql ( string -- ) >r db get r> execute-sql* ;\r
+: query-sql ( string -- ) >r db get r> query-sql* ;\r
 \r
+G: create-table* ( db tuple -- ) 1 standard-combination ;\r
+G: drop-table* ( db tuple -- ) 1 standard-combination ;\r
+G: insert-tuple* ( db tuple -- ) 1 standard-combination ;\r
+G: delete-tuple* ( db tuple -- ) 1 standard-combination ;\r
+G: update-tuple* ( db tuple -- ) 1 standard-combination ;\r
+G: select-tuple* ( db tuple -- ) 1 standard-combination ;\r
+\r
+TUPLE: persistent-error message ;\r
+\r
+: create-table ( tuple -- ) >r db get r> create-table* ;\r
+: drop-table ( tuple -- ) >r db get r> drop-table* ;\r
+: insert-tuple ( tuple -- ) \r
+    dup bottom-delegate persistent?\r
+    [\r
+        "tuple is persistent, call update not insert"\r
+        <persistent-error> throw\r
+    ] when\r
+    >r db get r> insert-tuple* ;\r
+\r
+: delete-tuple ( tuple -- )\r
+    dup bottom-delegate persistent?\r
+    [\r
+        "tuple is not persistent, cannot delete"\r
+        <persistent-error> throw\r
+    ] unless\r
+    >r db get r> delete-tuple* ;\r
+\r
+: update-tuple ( tuple -- )\r
+    dup bottom-delegate persistent?\r
+    [\r
+        "tuple is not persistent, call insert not update"\r
+        <persistent-error> throw\r
+    ] unless\r
+    >r db get r> update-tuple* ;\r
+\r
+: select-tuple ( tuple -- )\r
+    >r db get r> select-tuple* ;\r
 \r

diff --git a/libs/sql/simple.factor b/libs/sql/simple.factor
index 10a083f74574f2dcdac84868385200eb01336a41..64f912a26bbf6bab8f868583f69c5b22c2345353 100644 (file)
--- a/libs/sql/simple.factor
+++ b/libs/sql/simple.factor
@@ -1,52 +1,53 @@
-USING: generic kernel namespaces prettyprint sequences sql:utils ;\r
+USING: errors generic kernel namespaces prettyprint\r
+sequences sql:utils ;\r
 IN: sql\r
 \r
-GENERIC: create-sql* ( tuple db -- string )\r
-GENERIC: drop-sql* ( tuple db -- string )\r
-GENERIC: insert-sql* ( tuple db -- string )\r
-GENERIC: delete-sql* ( tuple db -- string )\r
-GENERIC: update-sql* ( tuple db -- string )\r
-GENERIC: select-sql* ( tuple db -- string )\r
-\r
-: create-sql ( tuple -- string ) db get create-sql* ;\r
-: drop-sql ( tuple -- string ) db get drop-sql* ;\r
-: insert-sql ( tuple -- string ) db get insert-sql* ;\r
-: delete-sql ( tuple -- string ) db get delete-sql* ;\r
-: update-sql ( tuple -- string ) db get update-sql* ;\r
-: select-sql ( tuple -- string ) db get select-sql* ;\r
-\r
-M: connection create-sql* ( tuple db -- string )\r
-    drop [\r
+G: create-sql* ( db tuple -- string ) 1 standard-combination ;\r
+G: drop-sql* ( db tuple -- string ) 1 standard-combination ;\r
+G: insert-sql* ( db tuple -- string ) 1 standard-combination ;\r
+G: delete-sql* ( db tuple -- string ) 1 standard-combination ;\r
+G: update-sql* ( db tuple -- string ) 1 standard-combination ;\r
+G: select-sql* ( db tuple -- string ) 1 standard-combination ;\r
+\r
+: create-sql ( tuple -- string ) >r db get r> create-sql* ;\r
+: drop-sql ( tuple -- string ) >r db get r> drop-sql* ;\r
+: insert-sql ( tuple -- string ) >r db get r> insert-sql* ;\r
+: delete-sql ( tuple -- string ) >r db get r> delete-sql* ;\r
+: update-sql ( tuple -- string ) >r db get r> update-sql* ;\r
+: select-sql ( tuple -- string ) >r db get r> select-sql* ;\r
+\r
+M: connection create-sql* ( db tuple -- string )\r
+    nip [\r
         "create table " %\r
         dup class unparse % "(" %\r
         tuple>mapping%\r
         ");" %\r
     ] "" make ;\r
 \r
-M: connection drop-sql* ( tuple db -- string )\r
-    drop [ "drop table " % tuple>sql-name % ";" % ] "" make ;\r
+M: connection drop-sql* ( db tuple -- string )\r
+    nip [ "drop table " % tuple>sql-name % ";" % ] "" make ;\r
 \r
-M: connection insert-sql* ( tuple db -- string )\r
-    drop [\r
+M: connection insert-sql* ( db tuple -- string )\r
+    nip [\r
         "insert into " %\r
         dup tuple>sql-name %\r
-        " (" % tuple>insert-parts dup first ", " join %\r
+        ! " (" % fulltuple>insert-all-parts dup first ", " join %\r
         ") values(" %\r
         second [ escape-sql enquote ] map ", " join %\r
         ");" %\r
     ] "" make ;\r
 \r
-M: connection delete-sql* ( tuple db -- string )\r
-    drop [\r
+M: connection delete-sql* ( db tuples -- string )\r
+    nip [\r
         ! "delete from table " % unparse % ";" %\r
     ] "" make ;\r
 \r
-M: connection update-sql* ( tuples db -- string )\r
-    drop [\r
+M: connection update-sql* ( db tuples -- string )\r
+    nip [\r
     ] "" make ;\r
 \r
-M: connection select-sql* ( tuples db -- string )\r
-    drop [\r
+M: connection select-sql* ( db tuples -- string )\r
+    nip [\r
     ] "" make ;\r
 \r
 \r

diff --git a/libs/sql/sql.factor b/libs/sql/sql.factor
index 677993983ab14308d15381cd0a1ff7b0d19c4f6b..e47c54e12a28bfb8e3b86392d222588fa6c5024d 100644 (file)
--- a/libs/sql/sql.factor
+++ b/libs/sql/sql.factor
@@ -3,6 +3,7 @@ IN: sql
 \r
 SYMBOL: db\r
 TUPLE: connection handle ;\r
+TUPLE: persistent id ;\r
 \r
 ! TESTING\r
 "handle" <connection> db set-global\r

diff --git a/libs/sql/sqlite/execute.factor b/libs/sql/sqlite/execute.factor
index f75342a1c512f3035f639d5b13e21655edbbf76e..3b0276928bc98f096f0b7fab0a76985225ee8459 100644 (file)
--- a/libs/sql/sqlite/execute.factor
+++ b/libs/sql/sqlite/execute.factor
@@ -1,7 +1,34 @@
-USING: kernel namespaces sql ;\r
+USING: kernel math namespaces sql sql:utils ;\r
 IN: sqlite\r
 \r
-M: sqlite execute-sql* ( string db -- )\r
-    connection-handle swap\r
+M: sqlite execute-sql* ( db string -- )\r
+    >r connection-handle r>\r
     sqlite-prepare dup [ drop ] sqlite-each sqlite-finalize ;\r
 \r
+M: sqlite create-table* ( db tuple -- )\r
+    create-sql execute-sql* ;\r
+\r
+M: sqlite drop-table* ( db tuple -- )\r
+    drop-sql execute-sql* ;\r
+\r
+M: sqlite insert-tuple* ( db tuple -- )\r
+    2dup insert-sql* >r >r connection-handle r> over r>\r
+    sqlite-prepare over bind-for-insert\r
+    [ drop ] sqlite-each sqlite-finalize\r
+    >r sqlite-last-insert-rowid number>string r> make-persistent ;\r
+\r
+M: sqlite delete-tuple* ( db tuple -- )\r
+    2dup delete-sql* >r >r connection-handle r> r>\r
+    swapd sqlite-prepare over bind-for-delete\r
+    [ drop ] sqlite-each sqlite-finalize remove-bottom-delegate ;\r
+\r
+M: sqlite update-tuple* ( db tuple -- )\r
+    2dup update-sql* >r >r connection-handle r> r>\r
+    swapd sqlite-prepare swap bind-for-update\r
+    [ drop ] sqlite-each sqlite-finalize drop ;\r
+\r
+M: sqlite select-tuple* ( db tuple -- )\r
+    2dup select-sql* >r >r connection-handle r> r>\r
+    swapd sqlite-prepare over bind-for-select\r
+    [ break [ break pick restore-tuple , ] sqlite-each ] { } make\r
+    [ sqlite-finalize ] keep ;\r

diff --git a/libs/sql/sqlite/simple.factor b/libs/sql/sqlite/simple.factor
index 9c45c17608d8e4be877a03d3808483b037f8b731..6970c91f107a266ec38d0bf53b99e3fc0f411a22 100644 (file)
--- a/libs/sql/sqlite/simple.factor
+++ b/libs/sql/sqlite/simple.factor
@@ -1,4 +1,4 @@
-USING: generic kernel namespaces prettyprint sql sql:utils ;\r
+USING: generic kernel namespaces prettyprint sequences sql sql:utils ;\r
 IN: sqlite\r
 \r
 TUPLE: sqlite ;\r
@@ -6,19 +6,59 @@ C: sqlite ( path -- db )
     >r sqlite-open <connection> r>\r
     [ set-delegate ] keep ;\r
 \r
-! M: sqlite insert-sql* ( tuple db -- string )\r
+M: sqlite create-sql* ( db tuple -- string )\r
+    nip [\r
+        "create table " % dup tuple>sql-name %\r
+        " (" % full-tuple>alist "id" alist-remove-key\r
+        [ first sanitize ] map ", " join %\r
+        ");" %\r
+    ] "" make ;\r
+\r
+M: sqlite insert-sql* ( db tuple -- string )\r
     #! Insert and fill in the ID column\r
-    ! ;\r
+    nip [\r
+        "insert into " %\r
+        dup tuple>sql-name %\r
+        " (" % tuple>insert-alist\r
+        [ [ first ] map ", " join % ] keep\r
+        ") values(" %\r
+        [ first field>sqlite-bind-name ] map ", " join %\r
+        ");" %\r
+    ] "" make ;\r
 \r
-M: sqlite delete-sql* ( tuple db -- string )\r
+M: sqlite delete-sql* ( db tuple -- string )\r
     #! Delete based on the ID column\r
-    ;\r
+    nip [\r
+        "delete from " % tuple>sql-name %\r
+        " where ROWID=:rowid;" %\r
+    ] "" make ;\r
 \r
-M: sqlite update-sql* ( tuple db -- string )\r
+M: sqlite update-sql* ( db tuple -- string )\r
     #! Update based on the ID column\r
-    ;\r
+    nip [\r
+        "update " % dup tuple>sql-name%\r
+        " set " % full-tuple>alist "id" alist-remove-key\r
+        [\r
+            [\r
+                first [ sanitize % ] keep\r
+                " = " % field>sqlite-bind-name %\r
+            ] "" make\r
+        ] map ", " join %\r
+        " where ROWID = :rowid;" %\r
+    ] "" make ;\r
 \r
-M: sqlite select-sql* ( tuple db -- string )\r
-    ;\r
+M: sqlite select-sql* ( db tuple -- string )\r
+    nip [\r
+        "select ROWID,* from " % dup tuple>sql-name %\r
+        " where " % tuple>select-alist\r
+        [\r
+            [\r
+                first dup %\r
+                " = " %\r
+                field>sqlite-bind-name %\r
+            ] "" make\r
+        ] map " and " join %\r
+        ";" %\r
+    ] "" make ;\r
 \r
 \r

diff --git a/libs/sql/sqlite/sqlite.factor b/libs/sql/sqlite/sqlite.factor
index a5b603a9494a25e4b7ac6ff502d7c1a4e425ff55..cf5d68ae02f9b2cf2e76f9e80b92dc6fc789ab5b 100644 (file)
--- a/libs/sql/sqlite/sqlite.factor
+++ b/libs/sql/sqlite/sqlite.factor
@@ -9,7 +9,8 @@
 ! executing SQL calls and obtaining results.
 !
 IN: sqlite
-USING: alien compiler errors libsqlite kernel namespaces sequences sql strings ;
+USING: alien compiler errors generic libsqlite kernel math namespaces
+prettyprint sequences sql strings sql:utils ;
 
 TUPLE: sqlite-error n message ;
 
@@ -52,7 +53,7 @@ TUPLE: sqlite-error n message ;
 : sqlite-bind-parameter-index ( statement name -- index )
   sqlite3_bind_parameter_index ;
 
-: sqlite-bind-text-by-name ( statement name text -- )
+ : sqlite-bind-text-by-name ( statement name text -- )
   >r dupd sqlite-bind-parameter-index r> sqlite-bind-text ;
 
 : sqlite-finalize ( statement -- )
@@ -124,3 +125,35 @@ DEFER: (sqlite-map)
         [ db get sqlite-close ] cleanup
     ] with-scope ;
 
+: bind-for-sql ( statement alist -- )
+    [
+        first2 >r field>sqlite-bind-name r>
+        obj>string/f sqlite-bind-text-by-name
+    ] each-with ;
+
+: bind-for-insert ( statement tuple -- )
+    tuple>insert-alist dupd dupd bind-for-sql ;
+
+: bind-for-update ( statement tuple -- )
+    tuple>update-alist dupd dupd dupd bind-for-sql ;
+
+: bind-for-delete ( statement tuple -- )
+    tuple>delete-alist dupd dupd bind-for-sql ;
+
+: bind-for-select ( statement tuple -- )
+    tuple>select-alist dupd dupd bind-for-sql ;
+
+: restore-tuple ( statement tuple -- tuple )
+    break
+    clone dup dup full-tuple>fields
+    [
+        2drop
+        ! over 1+ >r
+        ! db-field-slot >r
+        ! pick swap column-text
+        ! over r> set-slot r>
+    ] each-with
+    ! drop make-persistent swap 0 column-text swap
+    ! [ set-persistent-key ] keep
+    ;
+

diff --git a/libs/sql/tupledb.factor b/libs/sql/tupledb.factor
index 67276e1764650db4ee511972c8d41231d5349590..b9d45a5fa58d2c2fee23570da221825ac94235f8 100644 (file)
--- a/libs/sql/tupledb.factor
+++ b/libs/sql/tupledb.factor
@@ -1,14 +1,14 @@
 USING: kernel math sql:utils ;
 IN: sql
 
-: save ( tuple -- )
+: save-tuple ( tuple -- )
     dup "id" tuple-slot [
-        ! update
+        update-tuple
     ] [
-        ! insert
+        insert-tuple
     ] if ;
 
-: restore ( tuple -- )
+: restore-tuple ( tuple -- )
     ;
 
 

diff --git a/libs/sql/utils.factor b/libs/sql/utils.factor
index dd7efcf92b6832e178013c89fba4fdda463093e6..11736d172e8abc1ed918da381c7061c515a3081c 100644 (file)
--- a/libs/sql/utils.factor
+++ b/libs/sql/utils.factor
@@ -1,11 +1,47 @@
-USING: arrays errors generic hashtables kernel math namespaces\r
-prettyprint sequences sql strings tools words ;\r
+USING: arrays errors generic hashtables kernel kernel-internals\r
+math namespaces parser prettyprint sequences sql\r
+strings tools words ;\r
 IN: sql:utils\r
 \r
-! : 2seq>hash 2array flip alist>hash ;\r
+: sanitize ( string -- string )\r
+    "_p" "-?" pick subst ;\r
 \r
-: 2seq>hash ( seq seq -- hash )\r
-    H{ } clone -rot [ pick set-hash ] 2each ;\r
+: obj>string/f ( obj -- string/f )\r
+   dup [ dup string? [ unparse ] unless ] when ;\r
+\r
+: bottom-delegate ( tuple -- tuple/f )\r
+    dup delegate [ nip bottom-delegate ] when* ;\r
+\r
+: set-bottom-delegate ( delegate tuple -- )\r
+    bottom-delegate set-delegate ;\r
+\r
+: make-persistent ( id tuple -- )\r
+    >r <persistent> r> set-bottom-delegate ;\r
+\r
+: remove-bottom-delegate ( tuple -- )\r
+    dup delegate [\r
+        delegate [\r
+            delegate remove-bottom-delegate\r
+        ] [\r
+            f swap set-delegate\r
+        ] if\r
+    ] [\r
+        drop\r
+    ] if* ;\r
+\r
+: make-empty-tuple ( string -- tuple )\r
+    parse call dup tuple-size <tuple> ;\r
+\r
+: field>sqlite-bind-name ( string -- string )\r
+    >r ":" r> append sanitize ;\r
+\r
+: tuple-slot ( string tuple -- ? obj )\r
+    "slot-names" over class word-props hash\r
+    pick [ = ] curry find over -1 = [\r
+        2drop delegate dup [ tuple-slot ] [ 2drop f -1 ] if\r
+    ] [\r
+        drop rot drop 2 + swap tuple>array nth >r t r>\r
+    ] if ;\r
 \r
 : tuple-fields ( tuple -- seq )\r
     class "slot-names" word-prop ;\r
@@ -13,29 +49,61 @@ IN: sql:utils
 : tuple>parts ( tuple -- values names )\r
     [ tuple-slots ] keep tuple-fields ;\r
 \r
-: tuple>hash ( tuple -- hash )\r
-    tuple>parts 2seq>hash ;\r
-\r
-: tuple>all-slots\r
-    delegates <reversed> V{ } clone\r
-    [ tuple-slots dupd nappend ] reduce\r
-    <reversed> prune <reversed> >array ;\r
+: tuple>alist ( tuple -- alist )\r
+    tuple>parts [ swap 2array ] 2map ;\r
 \r
-: tuple>all-fields\r
+: full-tuple>fields ( tuple -- seq )\r
     delegates <reversed> V{ } clone\r
     [ tuple-fields dupd nappend ] reduce\r
     <reversed> prune <reversed> >array ;\r
+\r
+: full-tuple>slots ( tuple -- seq )\r
+    dup full-tuple>fields [ swap tuple-slot nip ] map-with ;\r
+\r
+: full-tuple>parts ( tuple -- values names )\r
+    [ full-tuple>slots ] keep full-tuple>fields ;\r
+\r
+: full-tuple>alist ( tuple -- alist )\r
+    full-tuple>parts [ swap 2array ] 2map ;\r
+\r
+: alist-remove-key ( alist key -- seq )\r
+    [ >r first r> = not ] curry subset ;\r
+\r
+: alist-remove-value ( alist value -- seq )\r
+    [ >r second r> = not ] curry subset ;\r
+\r
+: alist-key-each ( alist quot -- )\r
+    [ first ] swap append each ;\r
+\r
+: tuple>insert-alist ( tuple -- alist )\r
+    full-tuple>alist\r
+    "id" alist-remove-key\r
+    f alist-remove-value ;\r
+\r
+: tuple>update-alist ( tuple -- alist )\r
+    full-tuple>alist "id" over assoc\r
+    >r "rowid" r> 2array 1array append \r
+    "id" alist-remove-key ;\r
+\r
+: tuple>delete-alist ( tuple -- alist )\r
+    >r "rowid" r> "id" swap tuple-slot nip 2array 1array ;\r
+\r
+: tuple>select-alist ( tuple -- alist )\r
+    full-tuple>alist\r
+    f alist-remove-value ;\r
+\r
+! : 2seq>hash 2array flip alist>hash ;\r
+\r
+: 2seq>hash ( seq seq -- hash )\r
+    H{ } clone -rot [ pick set-hash ] 2each ;\r
+\r
+\r
+: tuple>hash ( tuple -- hash ) tuple>parts 2seq>hash ;\r
     \r
 : full-tuple>hash ( tuple -- hash )\r
     delegates <reversed>\r
     H{ } clone [ tuple>hash hash-union ] reduce ;\r
 \r
-: tuple>all-parts ( tuple -- values names )\r
-    [\r
-        [ full-tuple>hash ] keep tuple>all-fields\r
-        [ swap hash ] map-with\r
-    ] keep tuple>all-fields ;\r
-\r
 : maybe-unparse ( obj -- )\r
     dup string? [ unparse ] unless ;\r
 \r
@@ -49,20 +117,23 @@ IN: sql:utils
         ] { } make\r
     ] keep like ;\r
 \r
-GENERIC: escape-sql* ( string type db -- string )\r
-\r
-M: connection escape-sql* ( string type db -- string )\r
-    drop { "''" } "'" rot replace ;\r
+GENERIC: escape-sql* ( string db -- string )\r
 \r
-: escape-sql ( string type -- string ) db get escape-sql* ;\r
+M: connection escape-sql* ( string db -- string )\r
+    drop dup string? [\r
+        { "''" } "'" rot replace\r
+    ] when ;\r
 \r
-: sanitize-name ( string -- string )\r
-    "_p" "-?" pick subst ;\r
+: escape-sql ( string -- string ) db get escape-sql* ;\r
 \r
 : tuple>sql-name ( tuple -- string )\r
-    class unparse sanitize-name ;\r
+    class unparse sanitize ;\r
+\r
+: tuple>sql-name% ( tuple -- string )\r
+    tuple>sql-name % ;\r
+\r
 \r
-: enquote% "'" % % "'" % ;\r
+: enquote% "'" % dup string? [ unparse ] unless % "'" % ;\r
 \r
 : enquote ( string -- 'string' )\r
     [ enquote% ] "" make ;\r
@@ -78,7 +149,7 @@ M: connection escape-sql* ( string type db -- string )
     >r >r split-last r> each r> each ; inline\r
 \r
 : each-last ( seq quot quot -- )\r
-    >r dup clone r> append swap (each-last) ;\r
+    >r dup clone r> append swap (each-last) ; inline\r
 \r
 : (2each-last) ( seq seq quot quot -- )\r
     >r >r [ split-last ] 2apply swapd r> 2each r> 2each ; inline\r
@@ -86,7 +157,7 @@ M: connection escape-sql* ( string type db -- string )
 : 2each-last ( seq seq quot quot -- )\r
     #! apply first quotation on all but last elt of seq\r
     #! apply second quotation on last element\r
-    >r dup clone r> append swap (2each-last) ;\r
+    >r dup clone r> append swap (2each-last) ; inline\r
 \r
 ! <foo1> { integer string }\r
 ! mapping: { integer { varchar(256) "not null" } }\r
@@ -104,48 +175,15 @@ H{ } clone mappings set-global
 \r
 : tuple>mapping% ( obj -- seq )\r
     [ get-mapping ] keep tuple-fields\r
-    [ sanitize-name % " " % % ] [ ", " % ] 2each-last ;\r
+    [ sanitize % " " % % ] [ ", " % ] 2each-last ;\r
 \r
 : tuple>mapping ( tuple -- string )\r
     [ tuple>mapping% ] "" make ;\r
 \r
-: tuple>insert-parts ( tuple -- string )\r
-    [\r
-        tuple>parts\r
-        [\r
-            dup "id" = [\r
-                2drop\r
-            ] [\r
-                over [ swap 2array , ] [ 2drop ] if\r
-            ] if\r
-        ] 2each\r
-    ] { } make flip ;\r
-\r
-: tuple>assignments% ( tuple -- string )\r
-    [ tuple-slots [ maybe-unparse escape-sql ] map ] keep\r
-    tuple-fields\r
-    [ sanitize-name % " = " % enquote% ] [ ", " % ] 2each-last ;\r
-\r
-: tuple>assignments% ( tuple -- string )\r
-    tuple>parts dup [ "id" = ] find drop\r
-    dup -1 = [ "tuple must have an id slot" throw ] when\r
-    swap >r tuck >r remove-nth r> r> remove-nth\r
-    >r [ maybe-unparse escape-sql ] map r>\r
-    [ % " = " % enquote% ] [ ", " % ] 2each-last ;\r
-\r
-: tuple>assignments ( tuple -- string )\r
-    [ tuple>assignments% ] "" make ;\r
-\r
-: tuple-slot ( string slot -- ? obj )\r
-    "slot-names" over class word-props hash\r
-    rot [ = ] curry find over -1 = [\r
-        swap\r
-    ] [\r
-        drop 2 + swap tuple>array nth >r t r>\r
-    ] if ;\r
 \r
 : explode-tuple ( tuple -- )\r
     dup tuple-slots swap class "slot-names" word-prop\r
     [ set ] 2each ;\r
 \r
 \r
+\r