more work on libs/sql

libs/sql/execute.factor

@@ -1,10 +1,47 @@
-USING: kernel namespaces ;
+USING: errors generic kernel namespaces sql:utils ;
 IN: sql
 
-GENERIC: execute-sql* ( string db -- )
+G: execute-sql* ( db string -- ) 1 standard-combination ; 
-GENERIC: query-sql* ( string db -- seq )
+G: query-sql* ( db string -- seq ) 1 standard-combination ; 
 
-: execute-sql ( string -- ) db get execute-sql* ;
+: execute-sql ( string -- ) >r db get r> execute-sql* ;
-: query-sql ( string -- ) db get query-sql* ;
+: query-sql ( string -- ) >r db get r> query-sql* ;
 
+G: create-table* ( db tuple -- ) 1 standard-combination ;
+G: drop-table* ( db tuple -- ) 1 standard-combination ;
+G: insert-tuple* ( db tuple -- ) 1 standard-combination ;
+G: delete-tuple* ( db tuple -- ) 1 standard-combination ;
+G: update-tuple* ( db tuple -- ) 1 standard-combination ;
+G: select-tuple* ( db tuple -- ) 1 standard-combination ;
+
+TUPLE: persistent-error message ;
+
+: create-table ( tuple -- ) >r db get r> create-table* ;
+: drop-table ( tuple -- ) >r db get r> drop-table* ;
+: insert-tuple ( tuple -- ) 
+    dup bottom-delegate persistent?
+    [
+        "tuple is persistent, call update not insert"
+        <persistent-error> throw
+    ] when
+    >r db get r> insert-tuple* ;
+
+: delete-tuple ( tuple -- )
+    dup bottom-delegate persistent?
+    [
+        "tuple is not persistent, cannot delete"
+        <persistent-error> throw
+    ] unless
+    >r db get r> delete-tuple* ;
+
+: update-tuple ( tuple -- )
+    dup bottom-delegate persistent?
+    [
+        "tuple is not persistent, call insert not update"
+        <persistent-error> throw
+    ] unless
+    >r db get r> update-tuple* ;
+
+: select-tuple ( tuple -- )
+    >r db get r> select-tuple* ;
 

libs/sql/simple.factor

@@ -1,52 +1,53 @@
-USING: generic kernel namespaces prettyprint sequences sql:utils ;
+USING: errors generic kernel namespaces prettyprint
+sequences sql:utils ;
 IN: sql
 
-GENERIC: create-sql* ( tuple db -- string )
+G: create-sql* ( db tuple -- string ) 1 standard-combination ;
-GENERIC: drop-sql* ( tuple db -- string )
+G: drop-sql* ( db tuple -- string ) 1 standard-combination ;
-GENERIC: insert-sql* ( tuple db -- string )
+G: insert-sql* ( db tuple -- string ) 1 standard-combination ;
-GENERIC: delete-sql* ( tuple db -- string )
+G: delete-sql* ( db tuple -- string ) 1 standard-combination ;
-GENERIC: update-sql* ( tuple db -- string )
+G: update-sql* ( db tuple -- string ) 1 standard-combination ;
-GENERIC: select-sql* ( tuple db -- string )
+G: select-sql* ( db tuple -- string ) 1 standard-combination ;
 
-: create-sql ( tuple -- string ) db get create-sql* ;
+: create-sql ( tuple -- string ) >r db get r> create-sql* ;
-: drop-sql ( tuple -- string ) db get drop-sql* ;
+: drop-sql ( tuple -- string ) >r db get r> drop-sql* ;
-: insert-sql ( tuple -- string ) db get insert-sql* ;
+: insert-sql ( tuple -- string ) >r db get r> insert-sql* ;
-: delete-sql ( tuple -- string ) db get delete-sql* ;
+: delete-sql ( tuple -- string ) >r db get r> delete-sql* ;
-: update-sql ( tuple -- string ) db get update-sql* ;
+: update-sql ( tuple -- string ) >r db get r> update-sql* ;
-: select-sql ( tuple -- string ) db get select-sql* ;
+: select-sql ( tuple -- string ) >r db get r> select-sql* ;
 
-M: connection create-sql* ( tuple db -- string )
+M: connection create-sql* ( db tuple -- string )
-    drop [
+    nip [
         "create table " %
         dup class unparse % "(" %
         tuple>mapping%
         ");" %
     ] "" make ;
 
-M: connection drop-sql* ( tuple db -- string )
+M: connection drop-sql* ( db tuple -- string )
-    drop [ "drop table " % tuple>sql-name % ";" % ] "" make ;
+    nip [ "drop table " % tuple>sql-name % ";" % ] "" make ;
 
-M: connection insert-sql* ( tuple db -- string )
+M: connection insert-sql* ( db tuple -- string )
-    drop [
+    nip [
         "insert into " %
         dup tuple>sql-name %
-        " (" % tuple>insert-parts dup first ", " join %
+        ! " (" % fulltuple>insert-all-parts dup first ", " join %
         ") values(" %
         second [ escape-sql enquote ] map ", " join %
         ");" %
     ] "" make ;
 
-M: connection delete-sql* ( tuple db -- string )
+M: connection delete-sql* ( db tuples -- string )
-    drop [
+    nip [
         ! "delete from table " % unparse % ";" %
     ] "" make ;
 
-M: connection update-sql* ( tuples db -- string )
+M: connection update-sql* ( db tuples -- string )
-    drop [
+    nip [
     ] "" make ;
 
-M: connection select-sql* ( tuples db -- string )
+M: connection select-sql* ( db tuples -- string )
-    drop [
+    nip [
     ] "" make ;
 
 

libs/sql/sql.factor

@@ -3,6 +3,7 @@ IN: sql
 
 SYMBOL: db
 TUPLE: connection handle ;
+TUPLE: persistent id ;
 
 ! TESTING
 "handle" <connection> db set-global

libs/sql/sqlite/execute.factor

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

libs/sql/sqlite/simple.factor

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

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
+    ;
+

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 -- )
     ;
 
 

libs/sql/utils.factor

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