add composite primary keys to db

basis/db/postgresql/postgresql.factor

@@ -37,8 +37,7 @@ M: postgresql-db db-open ( db -- db )
 M: postgresql-db dispose ( db -- )
     handle>> PQfinish ;
 
-M: postgresql-statement bind-statement* ( statement -- )
+M: postgresql-statement bind-statement* ( statement -- ) drop ;
-    drop ;
 
 GENERIC: postgresql-bind-conversion ( tuple object -- low-level-binding )
 
@@ -67,11 +66,11 @@ M: postgresql-result-set #columns ( result-set -- n )
     [ handle>> ] [ n>> ] bi ;
 
 M: postgresql-result-set row-column ( result-set column -- object )
-    >r result-handle-n r> pq-get-string ;
+    [ result-handle-n ] dip pq-get-string ;
 
 M: postgresql-result-set row-column-typed ( result-set column -- object )
     dup pick out-params>> nth type>>
-    >r >r result-handle-n r> r> postgresql-column-typed ;
+    [ result-handle-n ] 2dip postgresql-column-typed ;
 
 M: postgresql-statement query-results ( query -- result-set )
     dup bind-params>> [
@@ -126,13 +125,20 @@ M: postgresql-db bind# ( spec object -- )
 
 : create-table-sql ( class -- statement )
     [
+        dupd
         "create table " 0% 0%
         "(" 0% [ ", " 0% ] [
             dup column-name>> 0%
             " " 0%
             dup type>> lookup-create-type 0%
             modifiers 0%
-        ] interleave ");" 0%
+        ] interleave
+
+        ", " 0%
+        find-primary-key
+        "primary key(" 0%
+        [ "," 0% ] [ column-name>> 0% ] interleave
+        "));" 0%
     ] query-make ;
 
 : create-function-sql ( class -- statement )
@@ -160,8 +166,7 @@ M: postgresql-db bind# ( spec object -- )
 M: postgresql-db create-sql-statement ( class -- seq )
     [
         [ create-table-sql , ] keep
-        dup db-columns find-primary-key db-assigned-id-spec?
+        dup db-assigned? [ create-function-sql , ] [ drop ] if
-        [ create-function-sql , ] [ drop ] if
     ] { } make ;
 
 : drop-function-sql ( class -- statement )
@@ -181,15 +186,14 @@ M: postgresql-db create-sql-statement ( class -- seq )
 M: postgresql-db drop-sql-statement ( class -- seq )
     [
         [ drop-table-sql , ] keep
-        dup db-columns find-primary-key db-assigned-id-spec?
+        dup db-assigned? [ drop-function-sql , ] [ drop ] if
-        [ drop-function-sql , ] [ drop ] if
     ] { } make ;
 
 M: postgresql-db <insert-db-assigned-statement> ( class -- statement )
     [
         "select add_" 0% 0%
         "(" 0%
-        dup find-primary-key 2,
+        dup find-primary-key first 2,
         remove-id
         [ ", " 0% ] [ bind% ] interleave
         ");" 0%
@@ -218,14 +222,14 @@ M: postgresql-db <insert-user-assigned-statement> ( class -- statement )
         ");" 0%
     ] query-make ;
 
-M: postgresql-db insert-tuple* ( tuple statement -- )
+M: postgresql-db insert-tuple-set-key ( tuple statement -- )
     query-modify-tuple ;
 
 M: postgresql-db persistent-table ( -- hashtable )
     H{
-        { +db-assigned-id+ { "integer" "serial primary key" f } }
+        { +db-assigned-id+ { "integer" "serial" f } }
-        { +user-assigned-id+ { f f "primary key" } }
+        { +user-assigned-id+ { f f f } }
-        { +random-id+ { "bigint" "bigint primary key" f } }
+        { +random-id+ { "bigint" "bigint" f } }
         { TEXT { "text" "text" f } }
         { VARCHAR { "varchar" "varchar" f } }
         { INTEGER { "integer" "integer" f } }

basis/db/queries/queries.factor

@@ -46,13 +46,18 @@ M: retryable execute-statement* ( statement type -- )
     [ db-columns ] [ db-table ] bi ;
 
 : query-make ( class quot -- )
-    >r sql-props r>
+    [ sql-props ] dip
-    [ 0 sql-counter rot with-variable ] curry { "" { } { } } nmake
+    [ 0 sql-counter rot with-variable ] curry
+    { "" { } { } } nmake
     <simple-statement> maybe-make-retryable ; inline
 
 : where-primary-key% ( specs -- )
     " where " 0%
-    find-primary-key dup column-name>> 0% " = " 0% bind% ;
+    find-primary-key [
+        " and " 0%
+    ] [
+        dup column-name>> 0% " = " 0% bind%
+    ] interleave ;
 
 M: db <update-tuple-statement> ( class -- statement )
     [
@@ -121,16 +126,15 @@ M: string where ( spec obj -- ) object-where ;
         dup double-infinite-interval? [ drop f ] when
     ] with filter ;
 
-: where-clause ( tuple specs -- )
+: many-where ( tuple seq -- )
-    dupd filter-slots [
+    " where " 0% [
-        drop
+        " and " 0%
     ] [
-        " where " 0% [
+        2dup slot-name>> swap get-slot-named where
-            " and " 0%
+    ] interleave drop ;
-        ] [
+
-            2dup slot-name>> swap get-slot-named where
+: where-clause ( tuple specs -- )
-        ] interleave drop
+    dupd filter-slots [ drop ] [ many-where ] if-empty ;
-    ] if-empty ;
 
 M: db <delete-tuples-statement> ( tuple table -- sql )
     [

basis/db/sqlite/sqlite.factor

@@ -88,7 +88,7 @@ M: sqlite-statement bind-tuple ( tuple statement -- )
     db get handle>> sqlite3_last_insert_rowid
     dup zero? [ "last-id failed" throw ] when ;
 
-M: sqlite-db insert-tuple* ( tuple statement -- )
+M: sqlite-db insert-tuple-set-key ( tuple statement -- )
     execute-statement last-insert-id swap set-primary-key ;
 
 M: sqlite-result-set #columns ( result-set -- n )
@@ -114,13 +114,20 @@ M: sqlite-statement query-results ( query -- result-set )
 
 M: sqlite-db create-sql-statement ( class -- statement )
     [
+        dupd
         "create table " 0% 0%
         "(" 0% [ ", " 0% ] [
             dup column-name>> 0%
             " " 0%
             dup type>> lookup-create-type 0%
             modifiers 0%
-        ] interleave ");" 0%
+        ] interleave
+
+        ", " 0%
+        find-primary-key
+        "primary key(" 0%
+        [ "," 0% ] [ column-name>> 0% ] interleave
+        "));" 0%
     ] query-make ;
 
 M: sqlite-db drop-sql-statement ( class -- statement )
@@ -161,10 +168,10 @@ M: sqlite-db bind% ( spec -- )
 
 M: sqlite-db persistent-table ( -- assoc )
     H{
-        { +db-assigned-id+ { "integer primary key" "integer primary key" "primary key" } }
+        { +db-assigned-id+ { "integer" "integer" f } }
-        { +user-assigned-id+ { f f "primary key" } }
+        { +user-assigned-id+ { f f f } }
-        { +random-id+ { "integer primary key" "integer primary key" "primary key" } }
+        { +random-id+ { "integer" "integer" f } }
-        { INTEGER { "integer" "integer" "primary key" } }
+        { INTEGER { "integer" "integer" f } }
         { BIG-INTEGER { "bigint" "bigint" } }
         { SIGNED-BIG-INTEGER { "bigint" "bigint" } }
         { UNSIGNED-BIG-INTEGER { "bigint" "bigint" } }

basis/db/tuples/tuples-tests.factor

@@ -513,15 +513,35 @@ string-encoding-test "STRING_ENCODING_TEST" {
 
 : test-queries ( -- )
     [ ] [ exam ensure-table ] unit-test
-    ! [ ] [ T{ exam f f "Kyle" 100 } insert-tuple ] unit-test
+    [ ] [ 1000 [ random-exam insert-tuple ] times ] unit-test
-    ! [ ] [ T{ exam f f "Stan" 80 } insert-tuple ] unit-test
+    [ 5 ] [
-    ! [ ] [ T{ exam f f "Kenny" 60 } insert-tuple ] unit-test
+        <query>
-    ! [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test
+        T{ exam { score T{ interval { from { 0 t } } { to { 100 t } } } } }
-    [ ] [ 10 [ random-exam insert-tuple ] times ] unit-test
+            >>tuple
-    [ 5 ] [ <query> T{ exam { score T{ interval { from { 0 t } } { to { 100 t } } } } } >>tuple 5 >>limit select-tuples length ] unit-test
+        5 >>limit select-tuples length
-    ! [ ] [ T{ exam { name "Kenny" } } >query  ] unit-test
+    ] unit-test ;
-    ! [ ] [ query ] unit-test
+
-    ;
+TUPLE: compound-foo a b c ;
+
+compound-foo "COMPOUND_FOO" 
+{
+    { "a" "A" INTEGER +user-assigned-id+ }
+    { "b" "B" INTEGER +user-assigned-id+ }
+    { "c" "C" INTEGER }
+} define-persistent
+
+: test-compound-primary-key ( -- )
+    [ ] [ compound-foo ensure-table ] unit-test
+    [ ] [ compound-foo drop-table ] unit-test
+    [ ] [ compound-foo create-table ] unit-test
+    [ ] [ 1 2 3 compound-foo boa insert-tuple ] unit-test
+    [ 1 2 3 compound-foo boa insert-tuple ] must-fail
+    [ ] [ 2 3 4 compound-foo boa insert-tuple ] unit-test
+    [ T{ compound-foo { a 2 } { b 3 } { c 4 } } ]
+    [ compound-foo new 4 >>c select-tuple ] unit-test ;
+
+[ test-compound-primary-key ] test-sqlite
+[ test-compound-primary-key ] test-postgresql
 
 : test-db ( -- )
     "tuples-test.db" temp-file sqlite-db make-db db-open db set ;

basis/db/tuples/tuples.factor

@@ -19,23 +19,7 @@ HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
 HOOK: <count-statement> db ( query -- statement )
 HOOK: query>statement db ( query -- statement )
 
-HOOK: insert-tuple* db ( tuple statement -- )
+HOOK: insert-tuple-set-key db ( tuple statement -- )
-
-ERROR: not-persistent class ;
-
-: db-table ( class -- object )
-    dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
-
-: db-columns ( class -- object )
-    superclasses [ "db-columns" word-prop ] map concat ;
-
-: db-relations ( class -- object )
-    "db-relations" word-prop ;
-
-: set-primary-key ( key tuple -- )
-    [
-        class db-columns find-primary-key slot-name>>
-    ] keep set-slot-named ;
 
 SYMBOL: sql-counter
 : next-sql-counter ( -- str )
@@ -69,7 +53,7 @@ GENERIC: eval-generator ( singleton -- object )
 : insert-db-assigned-statement ( tuple -- )
     dup class
     db get insert-statements>> [ <insert-db-assigned-statement> ] cache
-    [ bind-tuple ] 2keep insert-tuple* ;
+    [ bind-tuple ] 2keep insert-tuple-set-key ;
 
 : insert-user-assigned-statement ( tuple -- )
     dup class

basis/db/types/types.factor

@@ -30,14 +30,44 @@ UNION: +primary-key+ +db-assigned-id+ +user-assigned-id+ +random-id+ ;
 SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
 +foreign-id+ +has-many+ ;
 
+: offset-of-slot ( string tuple -- n )
+    class superclasses [ "slots" word-prop ] map concat
+    slot-named offset>> ;
+
+: get-slot-named ( name tuple -- value )
+    tuck offset-of-slot slot ;
+
+: set-slot-named ( value name obj -- )
+    tuck offset-of-slot set-slot ;
+
+ERROR: not-persistent class ;
+
+: db-table ( class -- object )
+    dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
+
+: db-columns ( class -- object )
+    superclasses [ "db-columns" word-prop ] map concat ;
+
+: db-relations ( class -- object )
+    "db-relations" word-prop ;
+
+: find-primary-key ( specs -- seq )
+    [ primary-key>> ] filter ;
+
+: set-primary-key ( value tuple -- )
+    [
+        class db-columns
+        find-primary-key first slot-name>>
+    ] keep set-slot-named ;
+
 : primary-key? ( spec -- ? )
     primary-key>> +primary-key+? ;
 
-: db-assigned-id-spec? ( spec -- ? )
+: db-assigned-id-spec? ( specs -- ? )
-    primary-key>> +db-assigned-id+? ;
+    [ primary-key>> +db-assigned-id+? ] contains? ;
 
-: assigned-id-spec? ( spec -- ? )
+: assigned-id-spec? ( specs -- ? )
-    primary-key>> +user-assigned-id+? ;
+    [ primary-key>> +user-assigned-id+? ] contains? ;
 
 : normalize-spec ( spec -- )
     dup type>> dup +primary-key+? [
@@ -49,8 +79,8 @@ SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
         [ >>primary-key drop ] [ drop ] if*
     ] if ;
 
-: find-primary-key ( specs -- obj )
+: db-assigned? ( class -- ? )
-    [ primary-key>> ] find nip ;
+    db-columns find-primary-key db-assigned-id-spec? ;
 
 : relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
 
@@ -125,13 +155,3 @@ ERROR: no-sql-type ;
 
 HOOK: bind% db ( spec -- )
 HOOK: bind# db ( spec obj -- )
-
-: offset-of-slot ( string tuple -- n )
-    class superclasses [ "slots" word-prop ] map concat
-    slot-named offset>> ;
-
-: get-slot-named ( name tuple -- value )
-    tuck offset-of-slot slot ;
-
-: set-slot-named ( value name obj -- )
-    tuck offset-of-slot set-slot ;