diff --git a/extra/db/db.factor b/extra/db/db.factor
index d88bbaee03..fe8459031e 100755
--- a/extra/db/db.factor
+++ b/extra/db/db.factor
@@ -23,12 +23,12 @@ HOOK: db-close db ( handle -- )
db-handle db-close
] with-variable ;
-TUPLE: statement sql params handle bound? slot-names ;
+TUPLE: statement handle sql slot-names bind-params bound? ;
TUPLE: simple-statement ;
TUPLE: prepared-statement ;
HOOK: <simple-statement> db ( str -- statement )
-HOOK: <prepared-statement> db ( str -- statement )
+HOOK: <prepared-statement> db ( str slot-names -- statement )
GENERIC: prepare-statement ( statement -- )
GENERIC: bind-statement* ( obj statement -- )
GENERIC: reset-statement ( statement -- )
@@ -47,7 +47,7 @@ GENERIC: more-rows? ( result-set -- ? )
: bind-statement ( obj statement -- )
dup statement-bound? [ dup reset-statement ] when
[ bind-statement* ] 2keep
- [ set-statement-params ] keep
+ [ set-statement-bind-params ] keep
t swap set-statement-bound? ;
: init-result-set ( result-set -- )
@@ -55,7 +55,7 @@ GENERIC: more-rows? ( result-set -- ? )
0 swap set-result-set-n ;
: <result-set> ( query handle tuple -- result-set )
- >r >r { statement-sql statement-params } get-slots r>
+ >r >r { statement-sql statement-bind-params } get-slots r>
{
set-result-set-sql
set-result-set-params
diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor
old mode 100644
new mode 100755
index c48eff964a..8a0e24e4cb
--- a/extra/db/postgresql/lib/lib.factor
+++ b/extra/db/postgresql/lib/lib.factor
@@ -37,8 +37,8 @@ IN: db.postgresql.lib
: do-postgresql-bound-statement ( statement -- res )
>r db get db-handle r>
[ statement-sql ] keep
- [ statement-params length f ] keep
- statement-params
+ [ statement-bind-params length f ] keep
+ statement-bind-params
[ first number>string* malloc-char-string ] map >c-void*-array
f f 0 PQexecParams
dup postgresql-result-ok? [
diff --git a/extra/db/postgresql/postgresql-tests.factor b/extra/db/postgresql/postgresql-tests.factor
old mode 100644
new mode 100755
index 9c98b53626..bdb434cfdd
--- a/extra/db/postgresql/postgresql-tests.factor
+++ b/extra/db/postgresql/postgresql-tests.factor
@@ -111,6 +111,8 @@ IN: temporary
] unit-test
+: with-dummy-db ( quot -- )
+ >r T{ postgresql-db } db r> with-variable ;
! TEST TUPLE DB
@@ -119,8 +121,8 @@ TUPLE: puppy id name age ;
{ set-puppy-name set-puppy-age } puppy construct ;
puppy "PUPPY" {
- { "id" "ID" +native-id+ }
- { "name" "NAME" TEXT }
+ { "id" "ID" +native-id+ +not-null+ }
+ { "name" "NAME" { VARCHAR 256 } }
{ "age" "AGE" INTEGER }
} define-persistent
@@ -129,7 +131,7 @@ TUPLE: kitty id name age ;
{ set-kitty-name set-kitty-age } kitty construct ;
kitty "KITTY" {
- { "id" "ID" +native-id+ }
+ { "id" "ID" INTEGER +assigned-id+ }
{ "name" "NAME" TEXT }
{ "age" "AGE" INTEGER }
} define-persistent
@@ -137,20 +139,226 @@ kitty "KITTY" {
TUPLE: basket id puppies kitties ;
basket "BASKET"
{
- { "id" "ID" +native-id+ }
+ { "id" "ID" +native-id+ +not-null+ }
{ "location" "LOCATION" TEXT }
{ "puppies" { +has-many+ puppy } }
{ "kitties" { +has-many+ kitty } }
} define-persistent
+! Create table
[
- { "name" "age" }
- ! "insert into table puppy(name, age) values($1, $2);"
- "select add_puppy($1, $2, $3);"
+ "create table puppy(id serial primary key not null, name varchar 256, age integer);"
] [
T{ postgresql-db } db [
- "Mr Clunkers" 3 <puppy>
- class dup db-columns swap db-table insert-sql* >lower
+ puppy dup db-columns swap db-table create-table-sql >lower
] with-variable
] unit-test
+[
+ "create table kitty(id integer primary key, name text, age integer);"
+] [
+ T{ postgresql-db } db [
+ kitty dup db-columns swap db-table create-table-sql >lower
+ ] with-variable
+] unit-test
+
+[
+ "create table basket(id serial primary key not null, location text);"
+] [
+ T{ postgresql-db } db [
+ basket dup db-columns swap db-table create-table-sql >lower
+ ] with-variable
+] unit-test
+
+! Create function
+[
+ "create function add_puppy(varchar,integer) returns bigint as 'insert into puppy(name, age) values($1, $2); select currval(''puppy_id_seq'');' language sql;"
+] [
+ T{ postgresql-db } db [
+ puppy dup db-columns swap db-table create-function-sql >lower
+ ] with-variable
+] unit-test
+
+! Drop table
+
+[
+ "drop table puppy;"
+] [
+ T{ postgresql-db } db [
+ puppy db-table drop-table-sql >lower
+ ] with-variable
+] unit-test
+
+[
+ "drop table kitty;"
+] [
+ T{ postgresql-db } db [
+ kitty db-table drop-table-sql >lower
+ ] with-variable
+] unit-test
+
+[
+ "drop table basket;"
+] [
+ T{ postgresql-db } db [
+ basket db-table drop-table-sql >lower
+ ] with-variable
+] unit-test
+
+
+! Drop function
+[
+ "drop function add_puppy(varchar, integer);"
+] [
+ T{ postgresql-db } db [
+ puppy dup db-columns swap db-table drop-function-sql >lower
+ ] with-variable
+] unit-test
+
+! Insert
+[
+ "select add_puppy($1, $2);"
+ {
+ T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } }
+ T{ sql-spec f "age" "AGE" INTEGER { } }
+ }
+ {
+ T{ sql-spec f "id" "ID" +native-id+ { +not-null+ } +native-id+ }
+ }
+] [
+ T{ postgresql-db } db [
+ puppy dup db-columns swap db-table insert-sql* >r >r >lower r> r>
+ ] with-variable
+] unit-test
+
+[
+ "insert into kitty(id, name, age) values($1, $2, $3);"
+ {
+ T{
+ sql-spec
+ f
+ "id"
+ "ID"
+ INTEGER
+ { +assigned-id+ }
+ +assigned-id+
+ }
+ T{ sql-spec f "name" "NAME" TEXT { } f }
+ T{ sql-spec f "age" "AGE" INTEGER { } f }
+ }
+ { }
+] [
+ T{ postgresql-db } db [
+ kitty dup db-columns swap db-table insert-sql* >r >r >lower r> r>
+ ] with-variable
+] unit-test
+
+! Update
+[
+ "update puppy set name = $1, age = $2 where id = $3"
+ {
+ T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f }
+ T{ sql-spec f "age" "AGE" INTEGER { } f }
+ T{
+ sql-spec
+ f
+ "id"
+ "ID"
+ +native-id+
+ { +not-null+ }
+ +native-id+
+ }
+ }
+ { }
+] [
+ T{ postgresql-db } db [
+ puppy dup db-columns swap db-table update-sql* >r >r >lower r> r>
+ ] with-variable
+] unit-test
+
+[
+ "update kitty set name = $1, age = $2 where id = $3"
+ {
+ T{ sql-spec f "name" "NAME" TEXT { } f }
+ T{ sql-spec f "age" "AGE" INTEGER { } f }
+ T{
+ sql-spec
+ f
+ "id"
+ "ID"
+ INTEGER
+ { +assigned-id+ }
+ +assigned-id+
+ }
+ }
+ { }
+] [
+ T{ postgresql-db } db [
+ kitty dup db-columns swap db-table update-sql* >r >r >lower r> r>
+ ] with-variable
+] unit-test
+
+! Delete
+[
+ "delete from puppy where id = $1"
+ {
+ T{
+ sql-spec
+ f
+ "id"
+ "ID"
+ +native-id+
+ { +not-null+ }
+ +native-id+
+ }
+ }
+ { }
+] [
+ T{ postgresql-db } db [
+ puppy dup db-columns swap db-table delete-sql* >r >r >lower r> r>
+ ] with-variable
+] unit-test
+
+[
+ "delete from KITTY where ID = $1"
+ {
+ T{
+ sql-spec
+ f
+ "id"
+ "ID"
+ INTEGER
+ { +assigned-id+ }
+ +assigned-id+
+ }
+ }
+ { }
+] [
+ T{ postgresql-db } db [
+ kitty dup db-columns swap db-table delete-sql*
+ ] with-variable
+] unit-test
+
+! Select
+[
+ "select from PUPPY ID, NAME, AGE where NAME = $1;"
+ { T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } }
+ {
+ T{
+ sql-spec
+ f
+ "id"
+ "ID"
+ +native-id+
+ { +not-null+ }
+ +native-id+
+ }
+ T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f }
+ T{ sql-spec f "age" "AGE" INTEGER { } f }
+ }
+] [
+ T{ postgresql-db } db [
+ T{ puppy f f "Mr. Clunkers" }
+ select-by-slots-sql
+ ] with-variable
+] unit-test
diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor
index b877d72060..3e949c3900 100755
--- a/extra/db/postgresql/postgresql.factor
+++ b/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 sequences.lib classes ;
+combinators sequences.lib classes locals words ;
IN: db.postgresql
TUPLE: postgresql-db host port pgopts pgtty db user pass ;
@@ -39,7 +39,7 @@ M: postgresql-db dispose ( db -- )
>r <postgresql-db> r> with-disposal ;
M: postgresql-statement bind-statement* ( seq statement -- )
- set-statement-params ;
+ set-statement-bind-params ;
M: postgresql-statement reset-statement ( statement -- )
drop ;
@@ -68,7 +68,7 @@ M: postgresql-statement insert-statement ( statement -- id )
query-results [ 0 row-column ] with-disposal string>number ;
M: postgresql-statement query-results ( query -- result-set )
- dup statement-params [
+ dup statement-bind-params [
over [ bind-statement ] keep
do-postgresql-bound-statement
] [
@@ -96,7 +96,7 @@ M: postgresql-result-set dispose ( result-set -- )
M: postgresql-statement prepare-statement ( statement -- )
[
>r db get db-handle "" r>
- dup statement-sql swap statement-params
+ dup statement-sql swap statement-bind-params
length f PQprepare postgresql-error
] keep set-statement-handle ;
@@ -104,9 +104,10 @@ M: postgresql-db <simple-statement> ( sql -- statement )
{ set-statement-sql } statement construct
<postgresql-statement> ;
-M: postgresql-db <prepared-statement> ( sql -- statement )
- { set-statement-sql } statement construct
- <postgresql-statement> ;
+M: postgresql-db <prepared-statement> ( pair -- statement )
+ ?first2
+ { set-statement-sql set-statement-slot-names }
+ statement construct <postgresql-statement> ;
M: postgresql-db begin-transaction ( -- )
"BEGIN" sql-command ;
@@ -117,134 +118,179 @@ M: postgresql-db commit-transaction ( -- )
M: postgresql-db rollback-transaction ( -- )
"ROLLBACK" sql-command ;
-: insert-function ( columns table -- sql types )
+: modifiers% ( spec -- )
+ sql-spec-modifiers
+ [ lookup-modifier ] map
+ " " join
+ dup empty? [ drop ] [ " " % % ] if ;
+
+SYMBOL: postgresql-counter
+: bind% ( spec -- )
+ 1,
+ CHAR: $ 0,
+ postgresql-counter [ inc ] keep get 0# ;
+
+: postgresql-make ( quot -- )
+ [ postgresql-counter off ] swap compose
+ { "" { } { } } nmake ;
+
+:: create-table-sql | specs table |
[
- >r remove-id r>
- "create function add_" % dup %
+ "create table " % table %
"(" %
- over [ "," % ]
- [ third dup array? [ first ] when >sql-type-string % ] interleave
- ")" %
- " returns bigint as '" %
+ specs [ ", " % ] [
+ dup sql-spec-column-name %
+ " " %
+ dup sql-spec-type t lookup-type %
+ modifiers%
+ ] interleave ");" %
+ ] "" make ;
- 2dup "insert into " %
- %
- "(" %
- dup [ ", " % ] [ second % ] interleave
- ") " %
- " values (" %
- length [1,b] [ ", " % ] [ "$" % # ] interleave
- "); " %
-
- "select currval(''" % % "_id_seq'');' language sql;" %
- drop
- ] "" make f ;
-
-: drop-function ( columns table -- sql )
+:: create-function-sql | specs table |
+ [
+ [let | specs [ specs remove-id ] |
+ "create function add_" 0% table 0%
+ "(" 0%
+ specs [ "," 0% ]
+ [
+ sql-spec-type f lookup-type 0%
+ ] interleave
+ ")" 0%
+ " returns bigint as '" 0%
+
+ "insert into " 0%
+ table 0%
+ "(" 0%
+ specs [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
+ ") values(" 0%
+ specs [ ", " 0% ] [ bind% ] interleave
+ "); " 0%
+
+ "select currval(''" 0% table 0% "_id_seq'');' language sql;" 0%
+ ]
+ ] postgresql-make 2drop ;
+
+: drop-function-sql ( specs table -- sql )
[
- >r remove-id r>
"drop function add_" % %
"(" %
- [ "," % ] [ third >sql-type-string % ] interleave
- ")" %
- ] "" nmake ;
-
-! M: postgresql-db create-sql ( columns table -- seq )
- ! [
- ! [
- ! 2dup
- ! "create table " % %
- ! " (" % [ ", " % ] [
- ! dup second % " " %
- ! dup third >sql-type-string % " " %
- ! sql-modifiers " " join %
- ! ] interleave "); " %
- ! ] "" make ,
-!
- ! over native-id? [ insert-function , ] [ 2drop ] if
- ! ] { } make ;
-
-M: postgresql-db drop-sql ( columns table -- seq )
- [
- [
- dup "drop table " % % ";" %
- ] "" make ,
- over native-id? [ drop-function , ] [ 2drop ] if
- ] { } make ;
-
-M: postgresql-db insert-sql* ( columns table -- sql slots )
- [
- "select add_" % %
- "(" %
- dup length [1,b] [ ", " % ] [ "$" % # ] interleave
+ remove-id
+ [ ", " % ] [ sql-spec-type f lookup-type % ] interleave
");" %
] "" make ;
-M: postgresql-db update-sql* ( columns table -- sql slots )
+: drop-table-sql ( table -- sql )
[
- "update " %
- %
- " set " %
+ "drop table " % % ";" %
+ ] "" make ;
+
+M: postgresql-db create-sql ( specs table -- seq )
+ [
+ 2dup create-table-sql ,
+ over find-primary-key native-id?
+ [ create-function-sql , ] [ 2drop ] if
+ ] { } make ;
+
+M: postgresql-db drop-sql ( specs table -- seq )
+ [
+ dup drop-table-sql ,
+ over find-primary-key native-id?
+ [ drop-function-sql , ] [ 2drop ] if
+ ] { } make ;
+
+: insert-table-sql ( specs table -- sql in-specs out-specs )
+ [
+ "insert into " 0% 0%
+ "(" 0%
+ dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
+ ")" 0%
+
+ " values(" 0%
+ [ ", " 0% ] [ bind% ] interleave
+ ");" 0%
+ ] postgresql-make ;
+
+: insert-function-sql ( specs table -- sql in-specs out-specs )
+ [
+ "select add_" 0% 0%
+ "(" 0%
+ dup find-primary-key 2,
+ remove-id
+ [ ", " 0% ] [ bind% ] interleave
+ ");" 0%
+ ] postgresql-make ;
+
+M: postgresql-db insert-sql* ( specs table -- sql in-specs out-specs )
+ over find-primary-key native-id?
+ [ insert-function-sql ] [ insert-table-sql ] if ;
+
+M: postgresql-db update-sql* ( specs table -- sql in-specs out-specs )
+ [
+ "update " 0% 0%
+ " set " 0%
dup remove-id
- dup length [1,b] swap 2array flip
- [ ", " % ] [ first2 second % " = $" % # ] interleave
- " where " %
- [ primary-key? ] find nip second dup % " = $" % length 2 + #
- ] "" make ;
+ [ ", " 0% ]
+ [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
+ " where " 0%
+ find-primary-key
+ dup sql-spec-column-name 0% " = " 0% bind%
+ ] postgresql-make ;
-M: postgresql-db delete-sql* ( columns table -- slot-names sql )
+M: postgresql-db delete-sql* ( specs table -- sql in-specs out-specs )
[
- "delete from " %
- %
- " where " %
- first second % " = $1" %
- ] "" make ;
+ "delete from " 0% 0%
+ " where " 0%
+ find-primary-key
+ dup sql-spec-column-name 0% " = " 0% bind%
+ ] postgresql-make ;
-: column-name% ( spec -- )
- 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 )
+: select-by-slots-sql ( tuple -- sql in-specs out-specs )
[
-
- ] { } 2 nmake ;
+ "select from " 0% dup class db-table 0%
+ " " 0%
+ dup class db-columns [ ", " 0% ]
+ [ dup sql-spec-column-name 0% 2, ] interleave
-M: postgresql-db tuple>params ( columns tuple -- obj )
+ dup class db-columns
+ [ sql-spec-slot-name swap get-slot-named ] with subset
+ " where " 0%
+ [ ", " 0% ]
+ [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
+ ";" 0%
+ ] postgresql-make ;
+
+! : select-with-relations ( tuple -- sql in-specs out-specs )
+
+M: postgresql-db select-sql ( tuple -- sql in-specs out-specs )
+ select-by-slots-sql ;
+
+M: postgresql-db tuple>params ( specs tuple -- obj )
[ >r dup third swap first r> get-slot-named swap ]
curry { } map>assoc ;
+
+M: postgresql-db type-table ( -- hash )
+ H{
+ { +native-id+ "integer" }
+ { TEXT "text" }
+ { VARCHAR "varchar" }
+ { INTEGER "integer" }
+ } ;
+
+M: postgresql-db create-type-table ( -- hash )
+ H{
+ { +native-id+ "serial primary key" }
+ } ;
+
+: postgresql-compound ( str n -- newstr )
+ dup number? [ "compound -- not a number" throw ] unless
+ number>string " " swap 3append ;
+
+M: postgresql-db compound-modifier ( str n -- newstr )
+ postgresql-compound ;
-: postgresql-db-modifiers ( -- hashtable )
+M: postgresql-db modifier-table ( -- hashtable )
H{
{ +native-id+ "primary key" }
- { +foreign-key+ "" }
{ +assigned-id+ "primary key" }
{ +autoincrement+ "autoincrement" }
{ +unique+ "unique" }
@@ -253,16 +299,5 @@ M: postgresql-db tuple>params ( columns tuple -- obj )
{ +not-null+ "not null" }
} ;
-! M: postgresql-db sql-modifier>string ( modifier -- str )
- ! dup array? [
- ! first2
- ! >r swap at r> number>string*
- ! " " swap 3append
- ! ] [
- ! swap at
- ! ] if ;
-!
-! M: postgresql-db sql-modifiers* ( modifiers -- str )
- ! postgresql-db-modifiers swap [
- ! sql-modifier>string
- ! ] with map [ ] subset ;
+M: postgresql-db compound-type ( str n -- newstr )
+ postgresql-compound ;
diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor
index 30ca260b93..9c22ba2a65 100755
--- a/extra/db/tuples/tuples.factor
+++ b/extra/db/tuples/tuples.factor
@@ -47,6 +47,7 @@ HOOK: insert-sql* db ( columns table -- sql slot-names )
HOOK: update-sql* db ( columns table -- sql slot-names )
HOOK: delete-sql* db ( columns table -- sql slot-names )
HOOK: select-sql db ( tuple -- seq/statement )
+HOOK: select-relations-sql db ( tuple -- seq/statement )
HOOK: row-column-typed db ( result-set n type -- sql )
HOOK: sql-type>factor-type db ( obj type -- obj )
@@ -101,7 +102,8 @@ HOOK: tuple>params db ( columns tuple -- obj )
: define-persistent ( class table columns -- )
>r dupd "db-table" set-word-prop dup r>
[ relation? ] partition swapd
- [ spec>tuple ] map "db-columns" set-word-prop
+ [ spec>tuple ] map
+ "db-columns" set-word-prop
"db-relations" set-word-prop ;
: tuple>filled-slots ( tuple -- alist )
@@ -117,13 +119,17 @@ SYMBOL: building-seq
: n, get-building-seq push ;
: n% get-building-seq push-all ;
+: n# >r number>string r> n% ;
: 0, 0 n, ;
: 0% 0 n% ;
+: 0# 0 n# ;
: 1, 1 n, ;
: 1% 1 n% ;
+: 1# 1 n# ;
: 2, 2 n, ;
: 2% 2 n% ;
+: 2# 2 n# ;
: nmake ( quot exemplars -- seqs )
dup length dup zero? [ 1+ ] when
diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor
index b75d3616f1..9354f4fe37 100755
--- a/extra/db/types/types.factor
+++ b/extra/db/types/types.factor
@@ -1,21 +1,38 @@
! 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.deep sequences.lib ;
+sequences continuations sequences.deep sequences.lib
+words ;
IN: db.types
+TUPLE: sql-spec slot-name column-name type modifiers primary-key ;
! ID is the Primary key
+! +native-id+ can be a columns type or a modifier
SYMBOL: +native-id+
+! +assigned-id+ can only be a modifier
SYMBOL: +assigned-id+
-: primary-key? ( spec -- ? )
- [ { +native-id+ +assigned-id+ } member? ] contains? ;
+: primary-key? ( obj -- ? )
+ { +native-id+ +assigned-id+ } member? ;
-: contains-id? ( columns id -- ? )
- swap [ member? ] with contains? ;
-
-: assigned-id? ( columns -- ? ) +assigned-id+ contains-id? ;
-: native-id? ( columns -- ? ) +native-id+ contains-id? ;
+: normalize-spec ( spec -- )
+ dup sql-spec-type dup primary-key? [
+ swap set-sql-spec-primary-key
+ ] [
+ drop dup sql-spec-modifiers [
+ primary-key?
+ ] deep-find
+ [ swap set-sql-spec-primary-key ] [ drop ] if*
+ ] if ;
+
+: find-primary-key ( specs -- obj )
+ [ sql-spec-primary-key ] find nip ;
+
+: native-id? ( spec -- ? )
+ sql-spec-primary-key +native-id+ = ;
+
+: assigned-id? ( spec -- ? )
+ sql-spec-primary-key +assigned-id+ = ;
SYMBOL: +foreign-key+
@@ -31,7 +48,7 @@ SYMBOL: +not-null+
SYMBOL: +has-many+
: relation? ( spec -- ? )
- [ +has-many+ = ] deep-find* nip ;
+ [ +has-many+ = ] deep-find ;
SYMBOL: INTEGER
SYMBOL: BIG_INTEGER
@@ -45,30 +62,15 @@ SYMBOL: VARCHAR
SYMBOL: TIMESTAMP
SYMBOL: DATE
-TUPLE: no-sql-type ;
-: no-sql-type ( -- * ) T{ no-sql-type } throw ;
-
-: 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 ;
-
-! 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 ;
+ [ ?first3 ] keep 3 ?tail*
+ {
+ set-sql-spec-slot-name
+ set-sql-spec-column-name
+ set-sql-spec-type
+ set-sql-spec-modifiers
+ } sql-spec construct
+ dup normalize-spec ;
: sql-type-hash ( -- assoc )
H{
@@ -79,16 +81,62 @@ TUPLE: sql-spec slot-name column-name type modifiers ;
{ TIMESTAMP "timestamp" }
} ;
-! HOOK: sql-type-hash db ( -- obj )
-! HOOK: >sql-type-string db ( obj -- str )
+TUPLE: no-sql-type ;
+: no-sql-type ( -- * ) T{ no-sql-type } throw ;
-: >sql-type-string ( obj -- str/f )
+TUPLE: no-sql-modifier ;
+: no-sql-modifier ( -- * ) T{ no-sql-modifier } throw ;
+
+: number>string* ( n/str -- str )
+ dup number? [ number>string ] when ;
+
+: maybe-remove-id ( specs -- obj )
+ [ native-id? not ] subset ;
+
+: remove-relations ( specs -- newcolumns )
+ [ relation? not ] subset ;
+
+: remove-id ( specs -- obj )
+ [ sql-spec-primary-key not ] subset ;
+
+! SQLite Types: http://www.sqlite.org/datatype3.html
+! NULL INTEGER REAL TEXT BLOB
+! PostgreSQL Types:
+! http://developer.postgresql.org/pgdocs/postgres/datatype.html
+
+
+
+HOOK: modifier-table db ( -- hash )
+HOOK: compound-modifier db ( str n -- hash )
+
+: lookup-modifier ( obj -- str )
dup pair? [
- first >sql-type-string
+ first2 >r lookup-modifier r> compound-modifier
] [
- sql-type-hash at* [ drop "" ] unless
+ modifier-table at*
+ [ "unknown modifier" throw ] unless
] if ;
-: full-sql-type-string ( obj -- str )
- [ >sql-type-string ] keep second
- number>string " " swap 3append ;
+
+HOOK: type-table db ( -- hash )
+HOOK: create-type-table db ( -- hash )
+HOOK: compound-type db ( str n -- hash )
+
+: lookup-type* ( obj -- str )
+ dup pair? [
+ first lookup-type*
+ ] [
+ type-table at*
+ [ no-sql-type ] unless
+ ] if ;
+
+: lookup-create-type ( obj -- str )
+ dup pair? [
+ first2 >r lookup-create-type r> compound-type
+ ] [
+ dup create-type-table at*
+ [ nip ] [ drop lookup-type* ] if
+ ] if ;
+
+: lookup-type ( obj create? -- str )
+ [ lookup-create-type ] [ lookup-type* ] if ;