intermediate work on db, everything is broken

extra/db/postgresql/postgresql-tests.factor

@@ -1,8 +1,9 @@
 ! You will need to run  'createdb factor-test' to create the database.
 ! Set username and password in  the 'connect' word.
 
-USING: kernel db.postgresql alien continuations io prettyprint
+USING: kernel db.postgresql alien continuations io classes
-sequences namespaces tools.test db db.types ;
+prettyprint sequences namespaces tools.test db
+db.tuples db.types unicode.case ;
 IN: temporary
 
 IN: scratchpad
@@ -108,3 +109,48 @@ IN: temporary
         "select * from person" sql-query length
     ] with-db
 ] unit-test
+
+
+
+! TEST TUPLE DB
+
+TUPLE: puppy id name age ;
+: <puppy> ( name age -- puppy )
+    { set-puppy-name set-puppy-age } puppy construct ;
+
+puppy "PUPPY" {
+    { "id" "ID" +native-id+ }
+    { "name" "NAME" TEXT }
+    { "age" "AGE" INTEGER }
+} define-persistent
+
+TUPLE: kitty id name age ;
+: <kitty> ( name age -- kitty )
+    { set-kitty-name set-kitty-age } kitty construct ;
+
+kitty "KITTY" {
+    { "id" "ID" +native-id+ }
+    { "name" "NAME" TEXT }
+    { "age" "AGE" INTEGER }
+} define-persistent
+
+TUPLE: basket id puppies kitties ;
+basket "BASKET"
+{
+    { "id" "ID" +native-id+ }
+    { "location" "LOCATION" TEXT }
+    { "puppies" { +has-many+ puppy } }
+    { "kitties" { +has-many+ kitty } }
+} define-persistent
+
+[
+    { "name" "age" }
+    ! "insert into table puppy(name, age) values($1, $2);"
+    "select add_puppy($1, $2, $3);"
+] [
+    T{ postgresql-db } db [
+        "Mr Clunkers" 3 <puppy>
+        class dup db-columns swap db-table insert-sql* >lower
+    ] with-variable
+] unit-test
+

extra/db/postgresql/postgresql.factor

@@ -4,7 +4,7 @@ USING: arrays assocs alien alien.syntax continuations io
 kernel math math.parser namespaces prettyprint quotations
 sequences debugger db db.postgresql.lib db.postgresql.ffi
 db.tuples db.types tools.annotations math.ranges
-combinators ;
+combinators sequences.lib classes ;
 IN: db.postgresql
 
 TUPLE: postgresql-db host port pgopts pgtty db user pass ;
@@ -117,52 +117,13 @@ M: postgresql-db commit-transaction ( -- )
 M: postgresql-db rollback-transaction ( -- )
     "ROLLBACK" sql-command ;
 
-: postgresql-type-hash* ( -- assoc )
+: insert-function ( columns table -- sql types )
-    H{
-        { SERIAL "serial" }
-    } ;
-
-: postgresql-type-hash ( -- assoc )
-    H{
-        { INTEGER "integer" }
-        { SERIAL "integer" }
-        { TEXT "text" }
-        { VARCHAR "varchar" }
-        { DOUBLE "real" }
-    } ;
-
-: enquote ( str -- newstr ) "(" swap ")" 3append ;
-
-: postgresql-type ( str n/str  -- newstr )
-    " " swap number>string* enquote 3append ;
-
-: >sql-type* ( obj -- str )
-    dup pair? [
-        first2 >r >sql-type* r> postgresql-type
-    ] [
-        dup postgresql-type-hash* at* [
-            nip
-        ] [
-            drop >sql-type
-        ] if
-    ] if ;
-
-M: postgresql-db >sql-type ( hash obj -- str )
-    dup pair? [
-        first2 >r >sql-type r> postgresql-type
-    ]  [
-        postgresql-type-hash at* [
-            no-sql-type
-        ] unless
-    ] if ;
-
-: insert-function ( columns table -- sql )
     [
         >r remove-id r>
         "create function add_" % dup %
         "(" %
         over [ "," % ]
-        [ third dup array? [ first ] when >sql-type % ] interleave
+        [ third dup array? [ first ] when >sql-type-string % ] interleave
         ")" %
         " returns bigint as '" %
 
@@ -177,31 +138,31 @@ M: postgresql-db >sql-type ( hash obj -- str )
 
         "select currval(''" % % "_id_seq'');' language sql;" %
         drop
-    ] "" make ;
+    ] "" make f ;
 
 : drop-function ( columns table -- sql )
     [
         >r remove-id r>
         "drop function add_" % %
         "(" %
-        [ "," % ] [ third >sql-type % ] interleave
+        [ "," % ] [ third >sql-type-string % ] interleave
         ")" %
-    ] "" make ;
+    ] "" nmake ;
 
-M: postgresql-db create-sql ( columns table -- seq )
+! M: postgresql-db create-sql ( columns table -- seq )
-    [
+    ! [
-        [
+        ! [
-            2dup
+            ! 2dup
-            "create table " % %
+            ! "create table " % %
-            " (" % [ ", " % ] [
+            ! " (" % [ ", " % ] [
-                dup second % " " %
+                ! dup second % " " %
-                dup third >sql-type* % " " %
+                ! dup third >sql-type-string % " " %
-                sql-modifiers " " join %
+                ! sql-modifiers " " join %
-            ] interleave "); " %
+            ! ] interleave "); " %
-        ] "" make ,
+        ! ] "" make ,
-
+! 
-        over native-id? [ insert-function , ] [ 2drop ] if
+        ! over native-id? [ insert-function , ] [ 2drop ] if
-    ] { } make ;
+    ! ] { } make ;
 
 M: postgresql-db drop-sql ( columns table -- seq )
     [
@@ -211,15 +172,15 @@ M: postgresql-db drop-sql ( columns table -- seq )
         over native-id? [ drop-function , ] [ 2drop ] if
     ] { } make ;
 
-M: postgresql-db insert-sql* ( columns table -- slot-names sql )
+M: postgresql-db insert-sql* ( columns table -- sql slots )
     [
         "select add_" % %
         "(" %
-        length [1,b] [ ", " % ] [ "$" % # ] interleave
+        dup length [1,b] [ ", " % ] [ "$" % # ] interleave
-        ")" %
+        ");" %
     ] "" make ;
 
-M: postgresql-db update-sql* ( columns table -- slot-names sql )
+M: postgresql-db update-sql* ( columns table -- sql slots )
     [
         "update " %
         %
@@ -239,8 +200,42 @@ M: postgresql-db delete-sql* ( columns table -- slot-names sql )
         first second % " = $1" %
     ] "" make ;
 
-M: postgresql-db select-sql ( columns table -- slot-names sql )
+: column-name% ( spec -- )
-    drop ;
+    dup sql-spec-column-name 0%
+    sql-spec-type >sql-type-string 1, ;
+
+: column-names% ( class -- )
+    db-columns [ "," 0, ] [ column-name% ] interleave ;
+
+M: postgresql-db column-bind% ( spec -- )
+    
+    
+    ;
+
+
+! : select-foreign-table-sql ( tuple relation -- )
+! ! select id, name, age from puppy, basket where puppy.basket_id = basket.id
+    ! "select " 0% 
+    ! ;
+! TODO
+: select-relations-sql ( tuple -- seq )
+    ! seq -- { sql types }
+    dup class db-relations [
+        [
+            ! select-foreign-table-sql
+        ] { "" { } } 2 nmake
+    ] with { } map>assoc ;
+
+! TODO
+: select-by-slots-sql ( tuple -- sql )
+    dup tuple>filled-slots
+    ;
+
+
+M: postgresql-db select-sql ( tuple -- sql slot-names )
+    [
+        
+    ] { } 2 nmake ;
 
 M: postgresql-db tuple>params ( columns tuple -- obj )
     [ >r dup third swap first r> get-slot-named swap ]
@@ -248,7 +243,8 @@ M: postgresql-db tuple>params ( columns tuple -- obj )
     
 : postgresql-db-modifiers ( -- hashtable )
     H{
-        { +native-id+ "not null primary key" }
+        { +native-id+ "primary key" }
+        { +foreign-key+ "" }
         { +assigned-id+ "primary key" }
         { +autoincrement+ "autoincrement" }
         { +unique+ "unique" }
@@ -257,13 +253,16 @@ M: postgresql-db tuple>params ( columns tuple -- obj )
         { +not-null+ "not null" }
     } ;
 
-M: postgresql-db sql-modifiers* ( modifiers -- str )
+! M: postgresql-db sql-modifier>string ( modifier -- str )
-    postgresql-db-modifiers swap [
+    ! dup array? [
-        dup array? [
+        ! first2
-            first2
+        ! >r swap at r> number>string*
-            >r swap at r> number>string*
+        ! " " swap 3append
-            " " swap 3append
+    ! ] [
-        ] [
+        ! swap at
-            swap at
+    ! ] if ;
-        ] if
+! 
-    ] with map [ ] subset ;
+! M: postgresql-db sql-modifiers* ( modifiers -- str )
+    ! postgresql-db-modifiers swap [
+        ! sql-modifier>string
+    ! ] with map [ ] subset ;

extra/db/tuples/tuples-tests.factor

@@ -54,7 +54,7 @@ person "PERSON"
 "billy" 10 3.14 <person> the-person set
 
 ! test-sqlite
- test-postgresql
+! test-postgresql
 
 ! person "PERSON"
 ! {
@@ -68,3 +68,42 @@ person "PERSON"
 
 ! test-sqlite
 ! test-postgresql
+
+TUPLE: paste n summary author channel mode contents timestamp annotations ;
+TUPLE: annotation n paste-id summary author mode contents ;
+
+paste "PASTE"
+{
+    { "n" "ID" SERIAL +native-id+ }
+    { "summary" "SUMMARY" TEXT }
+    { "author" "AUTHOR" TEXT }
+    { "channel" "CHANNEL" TEXT }
+    { "mode" "MODE" TEXT }
+    { "contents" "CONTENTS" TEXT }
+    { "date" "DATE" TIMESTAMP }
+    { "annotations" { +has-many+ annotation } }
+} define-persistent
+
+! n
+    ! NO: drop insert
+    ! YES: create update delete select
+! annotations
+    ! NO: create drop insert update delete
+    ! YES: select
+
+annotation "ANNOTATION"
+{
+    { "n" "ID" SERIAL +native-id+ }
+    { "paste-id" "PASTE_ID" INTEGER { +foreign-key+ paste "n" } }
+    { "summary" "SUMMARY" TEXT }
+    { "author" "AUTHOR" TEXT }
+    { "mode" "MODE" TEXT }
+    { "contents" "CONTENTS" TEXT }
+} define-persistent
+
+"localhost" "postgres" "" "factor-test" <postgresql-db> [
+    ! paste drop-table
+    ! annotation drop-table
+    paste create-table
+    annotation create-table
+] with-db

extra/db/tuples/tuples.factor

@@ -2,11 +2,13 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs classes db kernel namespaces
 tuples words sequences slots slots.private math
-math.parser io prettyprint db.types continuations ;
+math.parser io prettyprint db.types continuations
+mirrors sequences.lib ;
 IN: db.tuples
 
-: db-columns ( class -- obj ) "db-columns" word-prop ;
 : db-table ( class -- obj ) "db-table" word-prop ;
+: db-columns ( class -- obj ) "db-columns" word-prop ;
+: db-relations ( class -- obj ) "db-relations" word-prop ;
 
 TUPLE: no-slot-named ;
 : no-slot-named ( -- * ) T{ no-slot-named } throw ;
@@ -41,26 +43,15 @@ TUPLE: no-slot-named ;
 HOOK: create-sql db ( columns table -- seq )
 HOOK: drop-sql db ( columns table -- seq )
 
-HOOK: insert-sql* db ( columns table -- slot-names sql )
+HOOK: insert-sql* db ( columns table -- sql slot-names )
-HOOK: update-sql* db ( columns table -- slot-names sql )
+HOOK: update-sql* db ( columns table -- sql slot-names )
-HOOK: delete-sql* db ( columns table -- slot-names sql )
+HOOK: delete-sql* db ( columns table -- sql slot-names )
-HOOK: select-sql db ( tuple -- statement )
+HOOK: select-sql db ( tuple -- seq/statement )
 
 HOOK: row-column-typed db ( result-set n type -- sql )
 HOOK: sql-type>factor-type db ( obj type -- obj )
 HOOK: tuple>params db ( columns tuple -- obj )
 
-
-HOOK: make-slot-names* db ( quot -- seq )
-HOOK: column-slot-name% db ( spec -- )
-HOOK: column-bind-name% db ( spec -- )
-
-: make-slots-names ( quot -- seq str )
-    [ make-slot-names* ] "" make ; inline
-: slot-name% ( seq -- ) first % ;
-: column-name% ( seq -- ) second % ;
-: column-type% ( seq -- ) third % ;
-
 : insert-sql ( columns class -- statement )
     db get db-insert-statements [ insert-sql* ] cache-statement ;
 
@@ -108,8 +99,37 @@ HOOK: column-bind-name% db ( spec -- )
     dup primary-key [ update-tuple ] [ insert-tuple ] if ;
 
 : define-persistent ( class table columns -- )
-    >r dupd "db-table" set-word-prop r>
+    >r dupd "db-table" set-word-prop dup r>
-    "db-columns" set-word-prop ;
+    [ relation? ] partition swapd
+    [ spec>tuple ] map "db-columns" set-word-prop
+    "db-relations" set-word-prop ;
 
-: define-relation ( spec -- )
+: tuple>filled-slots ( tuple -- alist )
-    drop ;
+    dup <mirror> mirror-slots [ slot-spec-name ] map
+    swap tuple-slots 2array flip [ nip ] assoc-subset ;
+
+! [ tuple>filled-slots ] keep
+! [ >r first r> get-slot-named ] curry each
+
+SYMBOL: building-seq 
+: get-building-seq ( n -- seq )
+    building-seq get nth ;
+
+: n, get-building-seq push ;
+: n% get-building-seq push-all ;
+
+: 0, 0 n, ;
+: 0% 0 n% ;
+: 1, 1 n, ;
+: 1% 1 n% ;
+: 2, 2 n, ;
+: 2% 2 n% ;
+
+: nmake ( quot exemplars -- seqs )
+    dup length dup zero? [ 1+ ] when
+    [
+        [
+            [ drop 1024 swap new-resizable ] 2map
+            [ building-seq set call ] keep
+        ] 2keep >r [ like ] 2map r> firstn 
+    ] with-scope ;

extra/db/types/types.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs db kernel math math.parser
-sequences continuations ;
+sequences continuations sequences.deep sequences.lib ;
 IN: db.types
 
 ! ID is the Primary key
@@ -17,6 +17,8 @@ SYMBOL: +assigned-id+
 : assigned-id? ( columns -- ? ) +assigned-id+ contains-id? ;
 : native-id? ( columns -- ? ) +native-id+ contains-id? ;
 
+SYMBOL: +foreign-key+
+
 ! Same concept, SQLite has autoincrement, PostgreSQL has serial
 SYMBOL: +autoincrement+
 SYMBOL: +serial+
@@ -28,9 +30,13 @@ SYMBOL: +not-null+
 
 SYMBOL: +has-many+
 
-SYMBOL: SERIAL
+: relation? ( spec -- ? )
+    [ +has-many+ = ] deep-find* nip ;
+
 SYMBOL: INTEGER
+SYMBOL: BIG_INTEGER
 SYMBOL: DOUBLE
+
 SYMBOL: BOOLEAN
 
 SYMBOL: TEXT
@@ -39,29 +45,50 @@ SYMBOL: VARCHAR
 SYMBOL: TIMESTAMP
 SYMBOL: DATE
 
-SYMBOL: BIG_INTEGER
-
 TUPLE: no-sql-type ;
 : no-sql-type ( -- * ) T{ no-sql-type } throw ;
 
-HOOK: sql-modifiers* db ( modifiers -- str )
-HOOK: >sql-type db ( obj -- str )
-
-! HOOK: >factor-type db ( obj -- obj )
-
 : number>string* ( n/str -- str )
     dup number? [ number>string ] when ;
 
 : maybe-remove-id ( columns -- obj )
     [ +native-id+ swap member? not ] subset ;
 
+: remove-relations ( columns -- newcolumns )
+    [ relation? not ] subset ;
+
 : remove-id ( columns -- obj )
     [ primary-key? not ] subset ;
 
-: sql-modifiers ( spec -- seq )
-    3 tail sql-modifiers* ;
-
 ! SQLite Types: http://www.sqlite.org/datatype3.html
 ! NULL INTEGER REAL TEXT BLOB
 ! PostgreSQL Types:
 ! http://developer.postgresql.org/pgdocs/postgres/datatype.html
+
+TUPLE: sql-spec slot-name column-name type modifiers ;
+
+: spec>tuple ( spec -- tuple )
+    [ ?first3 ] keep 3 ?tail* sql-spec construct-boa ;
+
+: sql-type-hash ( -- assoc )
+    H{
+        { INTEGER "integer" }
+        { TEXT "text" }
+        { VARCHAR "varchar" }
+        { DOUBLE "real" }
+        { TIMESTAMP "timestamp" }
+    } ;
+
+! HOOK: sql-type-hash db ( -- obj )
+! HOOK: >sql-type-string db ( obj -- str )
+
+: >sql-type-string ( obj -- str/f )
+    dup pair? [
+        first >sql-type-string
+    ] [
+        sql-type-hash at* [ drop "" ] unless
+    ] if ;
+
+: full-sql-type-string ( obj -- str )
+    [ >sql-type-string ] keep second
+    number>string " " swap 3append ;